builtin.ml 11.7 KB
Newer Older
1
open Builtin_defs
2

3 4
let eval = ref (fun ppf err s -> assert false)

5 6
(* Types *)

7
let stringn = Types.cons string
8
let namespaces =
9
  Sequence.star (Types.times stringn stringn)
10

11
let types =
12
  [
13
    "Empty",   Types.empty;
14 15
    "Any",     any;
    "Int",     int;
16
    "Char",    Types.char Chars.any;
17
    "Byte",    char_latin1;
18
    "Atom",    atom;
19 20 21
    "Pair",    Types.Product.any;
    "Arrow",   Types.Arrow.any;
    "Record",  Types.Record.any;
22
    "String",  string;
23
    "Latin1",  string_latin1;
24 25
    "Bool",    bool;
    "Float",   float;
26
    "AnyXml",  any_xml;
27
    "Namespaces", namespaces;
28
    "Caml_int", caml_int;
29 30
  ]

31 32
let env =
  List.fold_left
33
    (fun accu (n,t) ->
34
       let n = (Ns.empty, Ident.U.mk n) in
35
       Types.Print.register_global ("",n,[]) t;
36 37
       Typer.enter_type (Ident.ident n) t accu
    )
38
    Typer.empty_env
39 40 41 42
    types

(* Operators *)

43 44
open Operators

45
let binary_op_gen = register_binary
46

47
let unary_op_gen = register_unary
48 49 50 51 52


let binary_op name t1 t2 f run =
  binary_op_gen
    name
53
    (fun arg1 arg2 constr precise ->
54 55 56
       f (arg1 t1 true) (arg2 t2 true))
    run

57 58
let binary_op_cst = register_op2

59 60 61

let binary_op_warning2 name t1 t2 w2 t run =
  binary_op_gen name
62
    (fun arg1 arg2 constr precise ->
63
       ignore (arg1 t1 false);
64 65
       let r = arg2 t2 true in
       if not (Types.subtype r w2) then
66
	 raise (Typer.Warning ("This operator may fail", t));
67 68 69 70
       t)
    run

let unary_op_warning name targ w t run =
71
  unary_op_gen name
72
    (fun arg constr precise ->
73 74
       let res = arg targ true in
       if not (Types.subtype res w) then
75
	 raise (Typer.Warning ("This operator may fail",t));
76 77
       t)
    run
78 79 80

open Ident

81 82 83
let raise_gen exn =
  raise (Value.CDuceExn (Value.string_latin1 (Printexc.to_string exn)))

84
let exn_load_file_utf8 = lazy (
85 86
  Value.CDuceExn (
    Value.Pair (
87
      Value.Atom (Atoms.V.mk_ascii "load_file_utf8"),
88
      Value.string_latin1 "File is not a valid UTF-8 stream", Value.Identity))
89
)
90

91
let exn_int_of =  lazy (
92 93
  Value.CDuceExn (
    Value.Pair (
94
      Value.Atom (Atoms.V.mk_ascii "Invalid_argument"),
95
      Value.string_latin1 "int_of", Value.Identity))
96
)
97

98
let exn_char_of = lazy (
99 100 101
  Value.CDuceExn (
    Value.Pair (
      Value.Atom (Atoms.V.mk_ascii "Invalid_argument"),
102
      Value.string_latin1 "char_of", Value.Identity))
103
)
104

105
let exn_float_of = lazy (
106 107 108
  Value.CDuceExn (
    Value.Pair (
      Value.Atom (Atoms.V.mk_ascii "Invalid_argument"),
109
      Value.string_latin1 "float_of", Value.Identity))
110 111 112
)

let exn_namespaces = lazy (
113 114 115
  Value.CDuceExn (
    Value.Pair (
      Value.Atom (Atoms.V.mk_ascii "Invalid_argument"),
116
      Value.string_latin1 "namespaces", Value.Identity))
117
)
118

Pietro Abate's avatar
Pietro Abate committed
119 120 121 122
let exn_cdata_of = lazy (
  Value.CDuceExn (
    Value.Pair (
      Value.Atom (Atoms.V.mk_ascii "Invalid_argument"),
123
      Value.string_latin1 "cdata_of", Value.Identity))
Pietro Abate's avatar
Pietro Abate committed
124
)
125 126

let eval_load_file ~utf8 e =
127
  Cduce_loc.protect_op "load_file";
128
  let fn = Value.get_string_latin1 e in
129
  let s = Url.load_url fn in
130 131 132
  if utf8 then
    match U.mk_check s with
      | Some s -> Value.string_utf8 s
133
      | None -> raise (Lazy.force exn_load_file_utf8)
134 135 136 137 138 139 140
  else Value.string_latin1 s


let () = ();;

(* Comparison operators *)

141 142
binary_op "="
  any any
143 144 145 146 147
  (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));;
148 149

binary_op_cst "<="
150 151
  any any bool
  (fun v1 v2 -> Value.vbool (Value.compare v1 v2 <= 0));;
152 153

binary_op_cst "<"
154 155
  any any bool
  (fun v1 v2 -> Value.vbool (Value.compare v1 v2 < 0));;
156 157

binary_op_cst ">="
158
  any any bool
159
  (fun v1 v2 ->
160
     Value.vbool (Value.compare v1 v2 >= 0));;
161 162

binary_op_cst ">"
163
  any any bool
164
  (fun v1 v2 ->
165 166 167
     Value.vbool (Value.compare v1 v2 > 0));;

(* I/O *)
168 169

register_fun "char_of_int"
170
  int (Types.char Chars.any)
171 172 173
  (function
     | Value.Integer x ->
	 (try Value.Char (Chars.V.mk_int (Intervals.V.get_int x))
174
	 with Failure _ -> raise (Lazy.force exn_int_of))
175 176
     | _ -> assert false);;

177
register_fun "int_of_char"
178
  (Types.char Chars.any) int
179 180 181 182 183
  (function
     | Value.Char x ->
	 Value.Integer (Intervals.V.from_int (Chars.V.to_int x))
     | _ -> assert false);;

184 185

register_fun "string_of"
186
  any string_latin1
187
  (fun v ->
188 189 190 191 192 193 194
     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)
  );;

195
register_fun "load_xml"
196
  string_latin1 any_xml
197
  (fun v -> Cduce_loc.protect_op "load_xml"; Load_xml.load_xml (Value.get_string_latin1 v));;
198

199 200
register_fun "!load_xml"
  string_latin1 any_xml
201
  (fun v -> Cduce_loc.protect_op "load_xml"; Load_xml.load_xml ~ns:true
202 203 204
     (Value.get_string_latin1 v));;


205 206
register_fun "load_html"
  string_latin1 Sequence.any
207
  (fun v -> Cduce_loc.protect_op "load_html"; Load_xml.load_html  (Value.get_string_latin1 v));;
208

209 210
register_fun "load_file_utf8"
  string_latin1 string
211 212
  (eval_load_file ~utf8:true);;

213 214
register_fun "load_file"
  string_latin1 string_latin1
215
  (eval_load_file ~utf8:false);;
216 217


218 219
let argv = ref Value.Absent;;

220

221

222
register_fun "print_xml"
223 224 225
  Types.any string_latin1
  (fun v -> Print_xml.print_xml ~utf8:false !Eval.ns_table v);;

226
register_fun "print_xml_utf8"
227 228
  Types.any string
  (fun v -> Print_xml.print_xml ~utf8:true !Eval.ns_table v);;
229

230

231
register_fun "dump_xml"
232 233
  Types.any nil
  (fun v ->
234
     Cduce_loc.protect_op "print";
235
     Print_xml.dump_xml ~utf8:false !Eval.ns_table v);;
236

237
register_fun "dump_xml_utf8"
238
  Types.any nil
239
  (fun v ->
240
     Cduce_loc.protect_op "print";
241
     Print_xml.dump_xml ~utf8:true !Eval.ns_table v);;
242 243


244 245
register_fun "print"
  string_latin1 nil
246
  (fun v ->
247
     Cduce_loc.protect_op "print";
248 249 250 251 252
     print_string (Value.get_string_latin1 v);
     flush stdout;
     Value.nil
  );;

253 254 255 256 257 258 259 260 261
register_fun "println"
  string_latin1 nil
  (fun v ->
     Cduce_loc.protect_op "println";
     print_endline (Value.get_string_latin1 v);
     flush stdout;
     Value.nil
  );;

262 263 264
register_fun "print_utf8"
  string nil
  (fun v ->
265
     Cduce_loc.protect_op "print";
266 267 268 269 270 271
     let s = Value.cduce2ocaml_string_utf8 v in
     print_string (U.get_str s);
     flush stdout;
     Value.nil
  );;

272 273 274 275
unary_op_warning "int_of"
  string intstr int
  (fun v ->
     let (s,_) = Value.get_string_utf8 v in
276 277 278 279 280 281 282
      let str = U.get_str s in
        try let modifier = str.[(String.index str '0')+1] in
	    if ( modifier = 'x' ||
                 modifier = 'X' ||
                 modifier = 'b' ||
                 modifier = 'B' ||
                 modifier = 'o' ||
283 284
                 modifier = 'O')
             then
285 286 287
               Value.Integer (Intervals.V.from_int (int_of_string(str)))
             else
	       Value.Integer (Intervals.V.mk (str))
288
         with _ ->
289
                (try Value.Integer (Intervals.V.mk (str))
290
                 with Failure _ -> raise (Lazy.force exn_int_of)));;
291

292 293 294 295
(*  It was like that                                    *)
(*     try Value.Integer (Intervals.V.mk (U.get_str s)) *)
(*                 UTF-8 is ASCII compatible !          *)
(* modified to allow 0x 0b 0o notations                 *)
296

297

298
(*
299
register_fun "atom_of"
300 301
  string atom
  (fun v ->
302
     let (s,_) = Value.get_string_utf8 v in
303
     Value.Atom (Atoms.V.mk Ns.empty s));;
304 305 306 307
*)

register_fun "split_atom"
  atom (Types.times stringn stringn)
308
  (function
309 310
     | Value.Atom q ->
	 let (ns,l) = Atoms.V.value q in
311
	 Value.Pair(
312
	   Value.string_utf8 (Ns.Uri.value ns),
313
	   Value.string_utf8 l, Value.Identity)
314 315 316 317 318 319 320 321 322
     | _ -> assert false);;

register_fun "make_atom"
  (Types.times stringn stringn) atom
  (fun v ->
     let v1,v2 =Value.get_pair v in
     let ns,_ = Value.get_string_utf8 v1 in
     let l,_ = Value.get_string_utf8 v2 in
     (* TODO: check that l is a correct Name wrt XML *)
323
     Value.Atom (Atoms.V.mk (Ns.Uri.mk ns, l)));;
324 325


326

327 328

binary_op_warning2 "dump_to_file"
329
  string_latin1 string string_latin1 nil
330
  (fun f v -> try
331
     Cduce_loc.protect_op "dump_to_file";
332 333 334
     let oc = open_out (Value.get_string_latin1 f) in
     output_string oc (Value.get_string_latin1 v);
     close_out oc;
335 336
     Value.nil
   with exn -> raise_gen exn);;
337

338
binary_op_cst "dump_to_file_utf8"
339
  string_latin1 string nil
340
  (fun f v -> try
341
     Cduce_loc.protect_op "dump_to_file_utf8";
342 343 344 345
     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;
346 347
     Value.nil
   with exn -> raise_gen exn);;
348 349 350

(* Integer operators *)

351
let intop f x y =
352 353
  let s = Types.BoolIntervals.leafconj x in
  let t = Types.BoolIntervals.leafconj y in
354
  (f s t)
355 356
;;

357
binary_op_gen "+"
358
  (fun arg1 arg2 constr precise ->
359
     let t1 = arg1 (Types.cup int Types.Record.any) true in
360
     if Types.subtype t1 int
361 362
     then (
       let t2 = arg2 int true in
363
       Types.interval
364
	 (intop Intervals.add (Types.Int.get t1) (Types.Int.get t2))
365
     )
366
     else if Types.subtype t1 Types.Record.any
367
     then (
368
       let t2 = arg2 Types.Record.any true in
369 370
       Types.Record.merge t1 t2
     )
371
     else raise (Typer.Error "The first argument mixes integers and records"))
372
  Value.add;;
373

374 375 376
binary_op "-"
  int int
  (fun t1 t2 ->
377
     Types.interval
378
     (intop Intervals.sub (Types.Int.get t1) (Types.Int.get t2)))
379
  (fun v1 v2 -> match (v1,v2) with
380
     | (Value.Integer x, Value.Integer y) -> Value.Integer (Intervals.V.sub x y)
381 382
     | _ -> assert false);;

383 384 385
binary_op "*"
  int int
  (fun t1 t2 ->
386
     Types.interval
387
     (intop Intervals.mul (Types.Int.get t1) (Types.Int.get t2)))
388
  (fun v1 v2 -> match (v1,v2) with
389
     | (Value.Integer x, Value.Integer y) -> Value.Integer (Intervals.V.mult x y)
390 391
     | _ -> assert false);;

392 393
binary_op_warning2 "/"
  int int non_zero_int int
394
  (fun v1 v2 -> match (v1,v2) with
395
     | (Value.Integer x, Value.Integer y) -> Value.Integer (Intervals.V.div x y)
396 397
     | _ -> assert false);;

398 399
binary_op_warning2 "mod"
  int int non_zero_int int
400
  (fun v1 v2 -> match (v1,v2) with
401
     | (Value.Integer x, Value.Integer y) -> Value.Integer (Intervals.V.modulo x y)
402 403 404 405
     | _ -> assert false);;


binary_op_gen "@"
406
  (fun arg1 arg2 constr precise ->
407
     let constr' = Sequence.ub_concat constr in
408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424
     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;;
425

426

427
register_fun "raise" any Types.empty
428
  (fun v -> raise (Value.CDuceExn v));;
429

430
register_fun "namespaces" any_xml
431
  namespaces
432
  (function
433
       Value.XmlNs (_,_,_,ns,s) ->
434 435
	 Value.sequence_rev
	   (List.map
436 437
	      (fun (pr,ns) ->
		 Value.Pair (Value.string_utf8 pr,
438
			     Value.string_utf8 (Ns.Uri.value ns), s))
439
	      (Ns.get_table ns))
440
     | Value.Xml _ -> raise (Lazy.force exn_namespaces)
441
     | _ -> assert false);;
442

443 444 445
register_fun2 "set_namespaces"
  namespaces any_xml any_xml
  (fun ns -> function
446
     | Value.XmlNs(v1,v2,v3,_,s) | Value.Xml (v1,v2,v3,s) ->
447 448 449 450 451
	 let ns = Value.get_sequence_rev ns in
	 let ns = List.map (fun v ->
			      let (pr,ns) = Value.get_pair v in
			      let pr,_ = Value.get_string_utf8 pr in
			      let ns,_ = Value.get_string_utf8 ns in
452
			      (pr,Ns.Uri.mk ns)) ns in
453
	 Value.XmlNs(v1,v2,v3,Ns.mk_table  ns, s)
454 455
     | _ -> assert false);;

456 457 458 459 460 461
(* Float *)

register_fun "float_of" string float
  (fun v ->
     let (s,_) = Value.get_string_utf8 v in
     try Value.float (float_of_string (U.get_str s))
462
     with Failure _ -> raise (Lazy.force exn_float_of));;
Pietro Abate's avatar
Pietro Abate committed
463 464 465 466 467 468 469 470

(* cdata *)

register_fun "cdata_of" string string
  (fun v ->
     let (s,_) = Value.get_string_utf8 v in
     try Value.cdata (U.get_str s)
     with Failure _ -> raise (Lazy.force exn_cdata_of));;