eval.ml 9.51 KB
Newer Older
1
2
open Value
open Run_dispatch
3
open Ident
4

5
exception MultipleDeclaration of id
6
module Env = Map.Make (Ident.Id)
7
8
type env = t Env.t

9
let global_env = State.ref "Eval.global_env" Env.empty
10
11
12

let enter_global x v = 
  if Env.mem x !global_env then
13
    raise (MultipleDeclaration x);
14
  global_env := Env.add x v !global_env
15
16


17
let exn_int_of = CDuceExn (Pair (
18
			     Atom (Atoms.mk_ascii "Invalid_argument"),
19
			     string_latin1 "int_of"))
20
21


22
23
24
let exn_load_file_utf8 = CDuceExn (Pair (
			     Atom (Atoms.mk_ascii "load_file_utf8"),
			     string_latin1 "File is not a valid UTF-8 stream"))
25
26
27
28
29
30
31
32
33
34
35
36
37


(* Evaluation of expressions *)

let rec eval env e0 = 
  match e0.Typed.exp_descr with
    | Typed.Forget (e,_) -> eval env e
    | Typed.Var s -> 
	(try Env.find s env
	with Not_found -> Env.find s !global_env)
    | Typed.Apply (f,arg) ->  eval_apply (eval env f) (eval env arg)
    | Typed.Abstraction a ->
	let env = 
38
	  IdSet.fold
39
40
41
42
43
44
45
46
47
48
49
50
51
52
	    (fun accu x -> 
	       try Env.add x (Env.find x env) accu
	       with Not_found -> accu (* global *))
	    Env.empty a.Typed.fun_fv in
	let env_ref = ref env in
	let rec self = Abstraction (a.Typed.fun_iface, 
				    eval_branches' env_ref a.Typed.fun_body) in
	(match a.Typed.fun_name with
	  | None -> ()
	  | Some f -> env_ref := Env.add f self env;
	);
	self
(* Optimizations:
       - for the non-recursive case, use eval_branches
53
       - for the recursive case, could cheat by patching self afterwards:
54
55
                (Obj.magic self).(1) <- ....
*)
56
    | Typed.RecordLitt r -> Record (LabelMap.map (eval env) r)
57
    | Typed.Pair (e1,e2) -> Pair (eval env e1, eval env e2)
58
59
    | Typed.Xml (e1, { Typed.exp_descr = Typed.Pair (e2,e3) }) -> 
	Xml (eval env e1, eval env e2, eval env e3)
60
61
    | Typed.Cst c -> const c
    | Typed.Match (arg,brs) -> eval_branches env brs (eval env arg)
62
63
    | Typed.Map (false,arg,brs) -> eval_map env brs (eval env arg)
    | Typed.Map (true,_,_) -> assert false
64
    | Typed.Xtrans (arg,brs) -> eval_xtrans env brs (eval env arg)
65
66
67
    | Typed.Op ("raise", [e]) -> raise (CDuceExn (eval env e))
    | Typed.Try (arg,brs) -> 
	(try eval env arg with CDuceExn v -> eval_branches env brs v)
68
    | Typed.Op ("flatten", [{Typed.exp_descr=Typed.Map (true,arg,brs)}]) -> 
69
	eval_transform env brs (eval env arg) 
70
71
72
73
74
75
    | Typed.Op ("flatten", [e]) -> eval_flatten (eval env e)
    | Typed.Op ("@", [e1; e2]) -> eval_concat (eval env e1) (eval env e2)
    | Typed.Op ("+", [e1; e2]) -> eval_add (eval env e1) (eval env e2)
    | Typed.Op ("*", [e1; e2]) -> eval_mul (eval env e1) (eval env e2)
    | Typed.Op ("-", [e1; e2]) -> eval_sub (eval env e1) (eval env e2)
    | Typed.Op ("/", [e1; e2]) -> eval_div (eval env e1) (eval env e2)
76
    | Typed.Op ("mod", [e1; e2]) -> eval_mod (eval env e1) (eval env e2)
77
    | Typed.Op ("load_xml", [e]) -> eval_load_xml (eval env e)
78
    | Typed.Op ("load_html", [e]) -> eval_load_html (eval env e)
79
80
    | Typed.Op ("load_file", [e]) -> eval_load_file ~utf8:false (eval env e)
    | Typed.Op ("load_file_utf8", [e]) -> eval_load_file ~utf8:true (eval env e)
81
82
    | Typed.Op ("print_xml", [e]) -> Print_xml.print_xml ~utf8:false (eval env e)
    | Typed.Op ("print_xml_utf8", [e]) -> Print_xml.print_xml ~utf8:true (eval env e)
83
    | Typed.Op ("print", [e]) -> eval_print (eval env e)
84
    | Typed.Op ("int_of", [e]) -> eval_int_of (eval env e)
85
    | Typed.Op ("atom_of", [e]) -> eval_atom_of (eval env e)
86
    | Typed.Op ("string_of", [e]) -> eval_string_of (eval env e)
87
88
    | Typed.Op ("dump_to_file", [e1; e2]) -> 
	eval_dump_to_file (eval env e1) (eval env e2)
89
90
    | Typed.Op ("dump_to_file_utf8", [e1; e2]) -> 
	eval_dump_to_file_utf8 (eval env e1) (eval env e2)
91
92
93
94
95
    | Typed.Op ("=",[e1; e2]) -> eval_equal (eval env e1) (eval env e2)
    | Typed.Op ("<",[e1; e2]) -> eval_lt (eval env e1) (eval env e2)
    | Typed.Op ("<=",[e1; e2]) -> eval_lte (eval env e1) (eval env e2)
    | Typed.Op (">",[e1; e2]) -> eval_gt (eval env e1) (eval env e2)
    | Typed.Op (">=",[e1; e2]) -> eval_gte (eval env e1) (eval env e2)
96
    | Typed.Dot (e, l) -> eval_dot l (eval env e)
97
    | Typed.RemoveField (e, l) -> eval_remove_field l (eval env e)
98
    | Typed.Op (o,_) -> failwith ("Unknown operator " ^ o)
99
    | _ -> assert false
100
101
102
103


and eval_apply f arg = match f with
  | Abstraction (_,clos) -> clos arg
104
  | _ -> eval_concat f arg
105
106
107
108
109
110
111

and eval_branches' env_ref brs arg =
  eval_branches !env_ref brs arg

and eval_branches env brs arg =
  let (disp, rhs) = Typed.dispatcher brs in
  let (code, bindings) = run_dispatcher disp arg in
112
113
114
115
116
117
118
119
  match rhs.(code) with 
    | Patterns.Compile.Match (bind,e) ->
	let env = 
	  List.fold_left (fun env (x,i) -> 
			    if (i == -1) then Env.add x arg env 
			    else Env.add x bindings.(i) env) env (IdMap.get bind) in
	eval env e
    | Patterns.Compile.Fail -> Value.Absent
120
121
122
123
124

and eval_let_decl env l =
  let v = eval env l.Typed.let_body in
  let (disp,bind) = Typed.dispatcher_let_decl l in
  let (_,bindings) = run_dispatcher disp v in
125
  List.map (fun (x,i) -> (x, if (i == -1) then v else bindings.(i))) (IdMap.get bind)
126
127

and eval_map env brs = function
128
129
130
  | Pair (x,y) -> 
      let x = eval_branches env brs x in
      Pair (x, eval_map env brs y)
131
132
  | String_latin1 (_,_,_,_) | String_utf8 (_,_,_,_) as v -> 
      eval_map env brs (normalize v)
133
134
135
136
137
138
  | q -> q
  
and eval_flatten = function
  | Pair (x,y) -> eval_concat x (eval_flatten y)
  | q -> q

139
and eval_transform env brs = function
140
  | Pair (x,y) -> 
141
      let x = match eval_branches env brs x with Value.Absent -> Value.nil | x -> x in
142
      eval_concat x (eval_transform env brs y)
143
144
145
146
  | String_latin1 (_,_,_,q) | String_utf8 (_,_,_,q) as v -> 
      if Types.Char.is_empty (brs.Typed.br_accept) 
      then eval_transform env brs q
      else eval_transform env brs (normalize v)
147
148
  | q -> q

149
and eval_xtrans env brs = function
150
151
152
153
154
155
156
157
  | String_utf8 (s,i,j,q) as v ->
      if Types.Char.is_empty (brs.Typed.br_accept) 
      then String_utf8 (s,i,j, eval_xtrans env brs q)
      else eval_xtrans env brs (normalize v)
  | String_latin1 (s,i,j,q) as v ->
      if Types.Char.is_empty (brs.Typed.br_accept) 
      then String_latin1 (s,i,j, eval_xtrans env brs q)
      else eval_xtrans env brs (normalize v)
158
  | Pair (x,y) -> 
159
160
161
      (match eval_branches env brs x with
	 | Absent -> 
	     let x = match x with
162
	       | Xml (tag, attr, child) -> 
163
		   let child = eval_xtrans env brs child in
164
		   Xml (tag, attr, child)
165
166
167
168
169
170
	       | x -> x in
	     let y = eval_xtrans env brs y in
	     Pair (x,y)
	 | x ->
	     let y = eval_xtrans env brs y in
	     eval_concat x y)
171
172
  | q -> q

173
174
and eval_concat l1 l2 = match l1 with
  | Pair (x,y) -> Pair (x, eval_concat y l2)
175
176
  | String_latin1 (s,i,j,q) -> String_latin1 (s,i,j, eval_concat q l2)
  | String_utf8 (s,i,j,q) -> String_utf8 (s,i,j, eval_concat q l2)
177
178
179
  | q -> l2

and eval_dot l = function
180
  | Record r -> LabelMap.assoc l r
181
182
  | _ -> assert false

183
184
185
186
and eval_remove_field l = function
  | Record r -> Record (LabelMap.remove l r)
  | _ -> assert false

187
and eval_add x y = match (x,y) with
188
  | (Integer x, Integer y) -> Integer (Intervals.vadd x y)
189
  | Record r1, Record r2 -> Record (LabelMap.merge (fun x y -> y) r1 r2)
190
191
192
  | _ -> assert false

and eval_mul x y = match (x,y) with
193
  | (Integer x, Integer y) -> Integer (Intervals.vmult x y)
194
195
196
  | _ -> assert false

and eval_sub x y = match (x,y) with
197
  | (Integer x, Integer y) -> Integer (Intervals.vsub x y)
198
199
200
  | _ -> assert false

and eval_div x y = match (x,y) with
201
  | (Integer x, Integer y) -> Integer (Intervals.vdiv x y)
202
203
  | _ -> assert false

204
and eval_mod x y = match (x,y) with
205
  | (Integer x, Integer y) -> Integer (Intervals.vmod x y)
206
207
  | _ -> assert false

208
and eval_load_xml e =
209
  Load_xml.load_xml (get_string_latin1 e)
210
211
    (* Note: loading iso-8859-1 (even ASCII) files with utf-8 internal
       encoding has a non negligible overhead with PXP *)
212
213

and eval_load_html e =
214
  Load_xml.load_html (get_string_latin1 e)
215

216
and eval_load_file ~utf8 e =
217
  Location.protect_op "load_file";
218
  let ic = open_in (get_string_latin1 e) in
219
220
221
222
  let len = in_channel_length ic in
  let s = String.create len in
  really_input ic s 0 len;
  close_in ic;
223
224
225
226
227
  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
228

229
and eval_int_of e =
230
231
  let (s,_) = get_string_utf8 e in
  try Integer (Intervals.mk (U.get_str s)) (* UTF-8 is ASCII compatible ! *)
232
  with Failure _ -> raise exn_int_of
233
234

and eval_atom_of e =
235
  let (s,_) = get_string_utf8 e in (* TODO: check that s is a correct Name wrt XML *)
236
  Atom (Atoms.mk s)
237
  
238
and eval_print v =
239
  Location.protect_op "print";
240
  print_string (get_string_latin1 v);
241
  flush stdout;
242
243
244
245
  Value.nil

and eval_dump_to_file f v =
  Location.protect_op "dump_to_file";
246
247
  let oc = open_out (get_string_latin1 f) in
  output_string oc (get_string_latin1 v);
248
249
  close_out oc;
  Value.nil
250
251
252
253
254
255
256
and eval_dump_to_file_utf8 f v =
  Location.protect_op "dump_to_file_utf8";
  let oc = open_out (get_string_latin1 f) in
  let (v,_) = get_string_utf8 v in
  output_string oc (U.get_str v);
  close_out oc;
  Value.nil
257

258
259
260
261
262
263

and eval_string_of v =
  let b = Buffer.create 16 in
  let ppf = Format.formatter_of_buffer b in
  Value.print ppf v;
  Format.pp_print_flush ppf ();
264
  string_latin1 (Buffer.contents b)
265
    
266
267
and eval_equal v1 v2 =
  let c = Value.compare v1 v2 in
268
  Value.vbool (Value.compare v1 v2 == 0)
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284

and eval_lt v1 v2 =
  let c = Value.compare v1 v2 in
  Value.vbool (Value.compare v1 v2 < 0)

and eval_lte v1 v2 =
  let c = Value.compare v1 v2 in
  Value.vbool (Value.compare v1 v2 <= 0)

and eval_gt v1 v2 =
  let c = Value.compare v1 v2 in
  Value.vbool (Value.compare v1 v2 > 0)

and eval_gte v1 v2 =
  let c = Value.compare v1 v2 in
  Value.vbool (Value.compare v1 v2 >= 0)