builtin.ml 7.88 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
    types

(* Operators *)

29
30
open Operators

31
let binary_op_gen name typ run =
32
33
34
35
36
37
38
  Binary.register name 
    (fun _ -> ())
    (fun () -> typ)
    (fun () -> run)
    (fun s () -> ())
    (fun s -> ())

39
40

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


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 =
75
76
77
78
79
80
81
  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
82
83

let unary_op_cst name targ t run =
84
85
86
87
88
  unary_op_gen name
    (fun loc arg constr precise ->
       ignore (arg targ false);
       t)
    run
89
90
91
92
93
94

open Ident

let exn_load_file_utf8 = 
  Value.CDuceExn (
    Value.Pair (
95
      Value.Atom (Atoms.V.mk_ascii "load_file_utf8"),
96
97
98
99
100
      Value.string_latin1 "File is not a valid UTF-8 stream"))

let exn_int_of = 
  Value.CDuceExn (
    Value.Pair (
101
      Value.Atom (Atoms.V.mk_ascii "Invalid_argument"),
102
103
      Value.string_latin1 "int_of"))

104
let exn_not_found =
105
  Value.CDuceExn (Value.Atom (Atoms.V.mk_ascii "Not_found"))
106

107
108
109
110
111
112
113
114
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 
115
116
117
    match U.mk_check s with 
      | Some s -> Value.string_utf8 s 
      | None -> raise exn_load_file_utf8
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
170
171
172
173
174
175
176
  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);;
177
178
179
180
181
182
183
184
185
186


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


187

188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
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;;

Unary.register "print_xml_tf8"
  (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;;
205
206
207
208
209
210
211
212
213
214
215
216
217
218

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
219
     try Value.Integer (Intervals.V.mk (U.get_str s)) (* UTF-8 is ASCII compatible ! *)
220
221
222
223
224
225
     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 *)
226
     Value.Atom (Atoms.V.mk Ns.empty s));;
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
258
259
260
261
262
263
264

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
265
     | (Value.Integer x, Value.Integer y) -> Value.Integer (Intervals.V.add x y)
266
267
268
269
270
271
272
273
274
     | (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
275
     | (Value.Integer x, Value.Integer y) -> Value.Integer (Intervals.V.sub x y)
276
277
278
279
280
     | _ -> assert false);;

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

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

binary_op_cst "mod"
  int int int
  (fun v1 v2 -> match (v1,v2) with
293
     | (Value.Integer x, Value.Integer y) -> Value.Integer (Intervals.V.modulo x y)
294
295
296
297
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
     | _ -> 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))