builtin.ml 8.19 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
19
    "Bool",    bool;
    "Float",   float;
20
21
  ]

22
23
let env =
  List.fold_left
24
25
26
27
28
    (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
    )
29
    Typer.empty_env
30
31
32
33
    types

(* Operators *)

34
35
open Operators

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

44
45

let unary_op_gen name typ run =
46
47
48
49
50
51
  Unary.register name 
    (fun _ -> ())
    (fun () -> typ)
    (fun () -> run)
    (fun s () -> ())
    (fun s -> ())
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
79


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 =
80
81
82
83
84
85
86
  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
87
88

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

open Ident

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

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

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

112
113
114
115
116
117
118
119
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 
120
121
122
    match U.mk_check s with 
      | Some s -> Value.string_utf8 s 
      | None -> raise exn_load_file_utf8
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
  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));;
  
146
binary_op_cst ">=" 
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
  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" 
173
  string Sequence.any
174
175
176
177
178
179
180
181
  (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);;
182
183
184
185
186
187
188
189
190
191


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


192

193
194
195
196
197
198
199
200
201
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;;

202
Unary.register "print_xml_utf8"
203
204
205
206
207
208
209
  (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;;
210
211
212
213
214
215
216
217
218
219
220
221
222
223

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
224
     try Value.Integer (Intervals.V.mk (U.get_str s)) (* UTF-8 is ASCII compatible ! *)
225
     with Failure _ -> raise exn_int_of);;
226
227
228
229
230
231
232

unary_op_cst "float_of"
  string float
  (fun v ->
     let (s,_) = Value.get_string_utf8 v in
     try Value.Abstract (float_abs, Obj.repr (float_of_string (U.get_str s)))
     with Failure _ -> raise exn_int_of);;
233
234
235
236
237

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 *)
238
     Value.Atom (Atoms.V.mk Ns.empty s));;
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
269
270
271
272
273
274
275
276

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
277
     | (Value.Integer x, Value.Integer y) -> Value.Integer (Intervals.V.add x y)
278
279
280
281
282
283
284
285
286
     | (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
287
     | (Value.Integer x, Value.Integer y) -> Value.Integer (Intervals.V.sub x y)
288
289
290
291
292
     | _ -> assert false);;

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

296
binary_op_cst "/"
297
298
  int int int
  (fun v1 v2 -> match (v1,v2) with
299
     | (Value.Integer x, Value.Integer y) -> Value.Integer (Intervals.V.div x y)
300
301
302
303
304
     | _ -> assert false);;

binary_op_cst "mod"
  int int int
  (fun v1 v2 -> match (v1,v2) with
305
     | (Value.Integer x, Value.Integer y) -> Value.Integer (Intervals.V.modulo x y)
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
     | _ -> 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))