builtin.ml 7.95 KB
Newer Older
1
open Builtin_defs
2

3
4
(* Types *)

5
6
7
let types =
  [ 
    "Empty",   Types.empty;
8
9
    "Any",     any;
    "Int",     int;
10
    "Char",    Types.char Chars.any;
11
    "Byte",    char_latin1;
12
    "Atom",    atom;
13
14
15
    "Pair",    Types.Product.any;
    "Arrow",   Types.Arrow.any;
    "Record",  Types.Record.any;
16
    "String",  string;
17
    "Latin1",  string_latin1;
18
    "Bool",    bool
19
20
  ]

21
22
let env =
  List.fold_left
23
24
25
26
27
    (fun accu (n,t) -> 
       let n = Ident.U.mk n in
       Types.Print.register_global n t;
       Typer.enter_type (Ident.ident n) t accu
    )
28
    Typer.empty_env
29
30
31
32
    types

(* Operators *)

33
34
open Operators

35
let binary_op_gen name typ run =
36
37
38
39
40
41
42
  Binary.register name 
    (fun _ -> ())
    (fun () -> typ)
    (fun () -> run)
    (fun s () -> ())
    (fun s -> ())

43
44

let unary_op_gen name typ run =
45
46
47
48
49
50
  Unary.register name 
    (fun _ -> ())
    (fun () -> typ)
    (fun () -> run)
    (fun s () -> ())
    (fun s -> ())
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78


let binary_op name t1 t2 f run =
  binary_op_gen
    name
    (fun loc arg1 arg2 constr precise ->
       f (arg1 t1 true) (arg2 t2 true))
    run

let binary_op_cst name t1 t2 t run =
  binary_op_gen name
    (fun loc arg1 arg2 constr precise ->
       ignore (arg1 t1 false); 
       ignore (arg2 t2 false); 
       t)
    run

let binary_op_warning2 name t1 t2 w2 t run =
  binary_op_gen name
    (fun loc arg1 arg2 constr precise ->
       ignore (arg1 t1 false); 
       let r = arg2 t2 true in
       if not (Types.subtype r w2) then
	 Typer.warning loc "This operator may fail";
       t)
    run

let unary_op_warning name targ w t run =
79
80
81
82
83
84
85
  unary_op_gen name
    (fun loc arg constr precise ->
       let res = arg targ true in
       if not (Types.subtype res w) then
	 Typer.warning loc "This operator may fail";
       t)
    run
86
87

let unary_op_cst name targ t run =
88
89
90
91
92
  unary_op_gen name
    (fun loc arg constr precise ->
       ignore (arg targ false);
       t)
    run
93
94
95
96
97
98

open Ident

let exn_load_file_utf8 = 
  Value.CDuceExn (
    Value.Pair (
99
      Value.Atom (Atoms.V.mk_ascii "load_file_utf8"),
100
101
102
103
104
      Value.string_latin1 "File is not a valid UTF-8 stream"))

let exn_int_of = 
  Value.CDuceExn (
    Value.Pair (
105
      Value.Atom (Atoms.V.mk_ascii "Invalid_argument"),
106
107
      Value.string_latin1 "int_of"))

108
let exn_not_found =
109
  Value.CDuceExn (Value.Atom (Atoms.V.mk_ascii "Not_found"))
110

111
112
113
114
115
116
117
118
let eval_load_file ~utf8 e =
  Location.protect_op "load_file";
  let ic = open_in (Value.get_string_latin1 e) in
  let len = in_channel_length ic in
  let s = String.create len in
  really_input ic s 0 len;
  close_in ic;
  if utf8 then 
119
120
121
    match U.mk_check s with 
      | Some s -> Value.string_utf8 s 
      | None -> raise exn_load_file_utf8
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
  else Value.string_latin1 s


let () = ();;

(* Comparison operators *)

binary_op "=" 
  any any 
  (fun t1 t2 ->
     if Types.is_empty (Types.cap t1 t2) then false_type
     else bool)
  (fun v1 v2 ->
     Value.vbool (Value.compare v1 v2 == 0));;
  
binary_op_cst "<=" 
  any any bool
  (fun v1 v2 -> Value.vbool (Value.compare v1 v2 <= 0));;
  
binary_op_cst "<" 
  any any bool
  (fun v1 v2 -> Value.vbool (Value.compare v1 v2 < 0));;
  
145
binary_op_cst ">=" 
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
  any any bool
  (fun v1 v2 -> 
     Value.vbool (Value.compare v1 v2 >= 0));;
  
binary_op_cst ">" 
  any any bool
  (fun v1 v2 -> 
     Value.vbool (Value.compare v1 v2 > 0));;

(* I/O *)
  
unary_op_cst "string_of" 
  any string_latin1
  (fun v -> 
     let b = Buffer.create 16 in
     let ppf = Format.formatter_of_buffer b in
     Value.print ppf v;
     Format.pp_print_flush ppf ();
     Value.string_latin1 (Buffer.contents b)
  );;

unary_op_cst "load_xml" 
  string any
  (fun v -> Load_xml.load_xml (Value.get_string_latin1 v));;
  
unary_op_cst "load_html" 
  string any
  (fun v -> Load_xml.load_html  (Value.get_string_latin1 v));;

unary_op_cst "load_file_utf8" 
  string string
  (eval_load_file ~utf8:true);;

unary_op_cst "load_file" string string_latin1
  (eval_load_file ~utf8:false);;
181
182
183
184
185
186
187
188
189
190


unary_op_cst "getenv" string_latin1 string_latin1
  (fun e ->
    Location.protect_op "getenv";
    let var = Value.get_string_latin1 e in
    try Value.string_latin1 (Sys.getenv var)
    with Not_found -> raise exn_not_found);;


191

192
193
194
195
196
197
198
199
200
Unary.register "print_xml"
  (fun tenv -> Typer.get_ns_table tenv)
  (fun ns_table loc arg constr precise -> 
     ignore (arg Types.any false);
     string_latin1)
  (Print_xml.print_xml ~utf8:false)
  Ns.serialize_table
  Ns.deserialize_table;;

201
Unary.register "print_xml_utf8"
202
203
204
205
206
207
208
  (fun tenv -> Typer.get_ns_table tenv)
  (fun ns_table loc arg constr precise -> 
     ignore (arg Types.any false);
     string)
  (Print_xml.print_xml ~utf8:true)
  Ns.serialize_table
  Ns.deserialize_table;;
209
210
211
212
213
214
215
216
217
218
219
220
221
222

unary_op_warning "print"
  string string_latin1 nil
  (fun v ->
     Location.protect_op "print";
     print_string (Value.get_string_latin1 v);
     flush stdout;
     Value.nil
  );;

unary_op_warning "int_of"
  string intstr int
  (fun v ->
     let (s,_) = Value.get_string_utf8 v in
223
     try Value.Integer (Intervals.V.mk (U.get_str s)) (* UTF-8 is ASCII compatible ! *)
224
225
226
227
228
229
     with Failure _ -> raise exn_int_of);;

unary_op_cst "atom_of"
  string atom
  (fun v ->
     let (s,_) = Value.get_string_utf8 v in (* TODO: check that s is a correct Name wrt XML *)
230
     Value.Atom (Atoms.V.mk Ns.empty s));;
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268

binary_op_warning2 "dump_to_file"
  string string string_latin1 nil
  (fun f v ->
     Location.protect_op "dump_to_file";
     let oc = open_out (Value.get_string_latin1 f) in
     output_string oc (Value.get_string_latin1 v);
     close_out oc;
     Value.nil);;
    
binary_op_cst "dump_to_file_utf8"
  string string nil
  (fun f v ->
     Location.protect_op "dump_to_file_utf8";
     let oc = open_out (Value.get_string_latin1 f) in
     let (v,_) = Value.get_string_utf8 v in
     output_string oc (U.get_str v);
     close_out oc;
     Value.nil);;

(* Integer operators *)

binary_op_gen "+"
  (fun loc arg1 arg2 constr precise ->
     let t1 = arg1 (Types.cup int Types.Record.any) true in
     if Types.subtype t1 int 
     then (
       let t2 = arg2 int true in
       Types.interval
	 (Intervals.add (Types.Int.get t1) (Types.Int.get t2))
     )
     else if Types.subtype t1 Types.Record.any 
     then (
       let t2 = arg2 Types.Record.any true in 
       Types.Record.merge t1 t2
     )
     else Typer.error loc "The first argument mixes integers and records")
  (fun v1 v2 -> match (v1,v2) with
269
     | (Value.Integer x, Value.Integer y) -> Value.Integer (Intervals.V.add x y)
270
271
272
273
274
275
276
277
278
     | (Value.Record r1, Value.Record r2) -> Value.Record (LabelMap.merge (fun x y -> y) r1 r2)
     | _ -> assert false);;
      
binary_op "-"
  int int
  (fun t1 t2 ->
     Types.interval 
     (Intervals.sub (Types.Int.get t1) (Types.Int.get t2)))
  (fun v1 v2 -> match (v1,v2) with
279
     | (Value.Integer x, Value.Integer y) -> Value.Integer (Intervals.V.sub x y)
280
281
282
283
284
     | _ -> assert false);;

binary_op_cst "*"
  int int int
  (fun v1 v2 -> match (v1,v2) with
285
     | (Value.Integer x, Value.Integer y) -> Value.Integer (Intervals.V.mult x y)
286
287
     | _ -> assert false);;

288
binary_op_cst "/"
289
290
  int int int
  (fun v1 v2 -> match (v1,v2) with
291
     | (Value.Integer x, Value.Integer y) -> Value.Integer (Intervals.V.div x y)
292
293
294
295
296
     | _ -> assert false);;

binary_op_cst "mod"
  int int int
  (fun v1 v2 -> match (v1,v2) with
297
     | (Value.Integer x, Value.Integer y) -> Value.Integer (Intervals.V.modulo x y)
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
     | _ -> assert false);;


binary_op_gen "@"
  (fun loc arg1 arg2 constr precise ->
     let constr' = Sequence.star 
		     (Sequence.approx (Types.cap Sequence.any constr)) in
     let exact = Types.subtype constr' constr in
     if exact then
       let t1 = arg1 constr' precise
       and t2 = arg2 constr' precise in
       if precise then Sequence.concat t1 t2 else constr
     else
       (* Note:
	  the knownledge of t1 may makes it useless to
	  check t2 with 'precise' ... *)
       let t1 = arg1 constr' true
       and t2 = arg2 constr' true in
       Sequence.concat t1 t2)
  Value.concat;;

unary_op_gen "flatten"
  Typer.flatten
  Value.flatten;;
  

unary_op_cst "raise"
  any Types.empty
  (fun v -> raise (Value.CDuceExn v))