builtin.ml 8.03 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
23
24
let env =
  List.fold_left
    (fun accu (n,t) -> Typer.enter_type (Ident.ident (Ident.U.mk n)) t accu)
    Typer.empty_env
25
26
27
28
29
    types

(* Operators *)

let binary_op_gen name typ run =
30
31
  Typer.register_binary_op name 
    (fun _ -> { Typed.bin_op_typer = typ; Typed.bin_op_eval = run })
32
33

let unary_op_gen name typ run =
34
35
  Typer.register_unary_op name 
    (fun _ -> { Typed.un_op_typer = typ; Typed.un_op_eval = run })
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63


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 =
64
65
  Typer.register_unary_op name 
    (fun _ ->
66
67
68
69
70
71
72
73
74
       { Typed.un_op_typer = 
	   (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);
	 Typed.un_op_eval = run })

let unary_op_cst name targ t run =
75
76
  Typer.register_unary_op name 
    (fun _ ->
77
78
79
80
81
82
83
84
85
86
87
       { Typed.un_op_typer = 
	   (fun loc arg constr precise ->
	      ignore (arg targ false);
	      t);
	 Typed.un_op_eval = run })

open Ident

let exn_load_file_utf8 = 
  Value.CDuceExn (
    Value.Pair (
88
      Value.Atom (Atoms.V.mk_ascii "load_file_utf8"),
89
90
91
92
93
      Value.string_latin1 "File is not a valid UTF-8 stream"))

let exn_int_of = 
  Value.CDuceExn (
    Value.Pair (
94
      Value.Atom (Atoms.V.mk_ascii "Invalid_argument"),
95
96
      Value.string_latin1 "int_of"))

97
let exn_not_found =
98
  Value.CDuceExn (Value.Atom (Atoms.V.mk_ascii "Not_found"))
99

100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
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 
    if U.check s 
    then Value.string_utf8 (U.mk s) 
    else raise exn_load_file_utf8
  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));;
  
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));;

(* 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);;
170
171
172
173
174
175
176
177
178
179


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);;


180

181
182
183
Typer.register_unary_op "print_xml"
  (fun tenv ->
     let ns_table = Typer.get_ns_table tenv in
184
185
186
187
     { Typed.un_op_typer = 
	 (fun loc arg constr precise -> 
	    ignore (arg Types.any false);
	    string_latin1);
188
189
190
191
192
       Typed.un_op_eval = Print_xml.print_xml ~utf8:false ns_table });;

Typer.register_unary_op "print_xml_utf8"
  (fun tenv ->
     let ns_table = Typer.get_ns_table tenv in
193
194
195
196
     { Typed.un_op_typer = 
	 (fun loc arg constr precise -> 
	    ignore (arg Types.any false);
	    string);
197
       Typed.un_op_eval = Print_xml.print_xml ~utf8:true ns_table });;
198
199
200
201
202
203
204
205
206
207
208
209
210
211

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
212
     try Value.Integer (Intervals.V.mk (U.get_str s)) (* UTF-8 is ASCII compatible ! *)
213
214
215
216
217
218
     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 *)
219
     Value.Atom (Atoms.V.mk Ns.empty s));;
220
221
222
223
224
225
226
227
228
229
230
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

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
258
     | (Value.Integer x, Value.Integer y) -> Value.Integer (Intervals.V.add x y)
259
260
261
262
263
264
265
266
267
     | (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
268
     | (Value.Integer x, Value.Integer y) -> Value.Integer (Intervals.V.sub x y)
269
270
271
272
273
     | _ -> assert false);;

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

277
binary_op_cst "/"
278
279
  int int int
  (fun v1 v2 -> match (v1,v2) with
280
     | (Value.Integer x, Value.Integer y) -> Value.Integer (Intervals.V.div x y)
281
282
283
284
285
     | _ -> assert false);;

binary_op_cst "mod"
  int int int
  (fun v1 v2 -> match (v1,v2) with
286
     | (Value.Integer x, Value.Integer y) -> Value.Integer (Intervals.V.modulo x y)
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
     | _ -> 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))