eval.ml 9.43 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
    | Typed.Xml (e1,e2) -> Xml (eval env e1, eval env e2)
59
60
    | Typed.Cst c -> const c
    | Typed.Match (arg,brs) -> eval_branches env brs (eval env arg)
61
62
    | Typed.Map (false,arg,brs) -> eval_map env brs (eval env arg)
    | Typed.Map (true,_,_) -> assert false
63
    | Typed.Xtrans (arg,brs) -> eval_xtrans env brs (eval env arg)
64
65
66
    | 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)
67
    | Typed.Op ("flatten", [{Typed.exp_descr=Typed.Map (true,arg,brs)}]) -> 
68
	eval_transform env brs (eval env arg) 
69
70
71
72
73
74
    | 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)
75
    | Typed.Op ("mod", [e1; e2]) -> eval_mod (eval env e1) (eval env e2)
76
    | Typed.Op ("load_xml", [e]) -> eval_load_xml (eval env e)
77
    | Typed.Op ("load_html", [e]) -> eval_load_html (eval env e)
78
79
    | 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)
80
81
    | 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)
82
    | Typed.Op ("print", [e]) -> eval_print (eval env e)
83
    | Typed.Op ("int_of", [e]) -> eval_int_of (eval env e)
84
    | Typed.Op ("atom_of", [e]) -> eval_atom_of (eval env e)
85
    | Typed.Op ("string_of", [e]) -> eval_string_of (eval env e)
86
87
    | Typed.Op ("dump_to_file", [e1; e2]) -> 
	eval_dump_to_file (eval env e1) (eval env e2)
88
89
    | Typed.Op ("dump_to_file_utf8", [e1; e2]) -> 
	eval_dump_to_file_utf8 (eval env e1) (eval env e2)
90
91
92
93
94
    | 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)
95
    | Typed.Dot (e, l) -> eval_dot l (eval env e)
96
    | Typed.RemoveField (e, l) -> eval_remove_field l (eval env e)
97
98
99
100
101
    | Typed.Op (o,_) -> failwith ("Unknown operator " ^ o)


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

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
110
111
112
113
114
115
116
117
  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
118
119
120
121
122

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
123
  List.map (fun (x,i) -> (x, if (i == -1) then v else bindings.(i))) (IdMap.get bind)
124
125

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

137
and eval_transform env brs = function
138
  | Pair (x,y) -> 
139
      let x = match eval_branches env brs x with Value.Absent -> Value.nil | x -> x in
140
      eval_concat x (eval_transform env brs y)
141
142
143
144
  | 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)
145
146
  | q -> q

147
and eval_xtrans env brs = function
148
149
150
151
152
153
154
155
  | 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)
156
  | Pair (x,y) -> 
157
158
159
160
161
162
163
164
165
166
167
168
169
      (match eval_branches env brs x with
	 | Absent -> 
	     let x = match x with
	       | Xml (tag, Pair (attr, child)) -> 
		   let child = eval_xtrans env brs child in
		   Xml (tag, Pair (attr, child))
	       | Xml (_,_) -> assert false
	       | 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)
170
171
  | q -> q

172
173
and eval_concat l1 l2 = match l1 with
  | Pair (x,y) -> Pair (x, eval_concat y l2)
174
175
  | 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)
176
177
178
  | q -> l2

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

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

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

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

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

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

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

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

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

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

228
and eval_int_of e =
229
  let s = get_string_latin1 e in
230
  try Integer (Intervals.mk s)
231
  with Failure _ -> raise exn_int_of
232
233

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

and eval_dump_to_file f v =
  Location.protect_op "dump_to_file";
245
246
  let oc = open_out (get_string_latin1 f) in
  output_string oc (get_string_latin1 v);
247
248
  close_out oc;
  Value.nil
249
250
251
252
253
254
255
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
256

257
258
259
260
261
262

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 ();
263
  string_latin1 (Buffer.contents b)
264
    
265
266
and eval_equal v1 v2 =
  let c = Value.compare v1 v2 in
267
  Value.vbool (Value.compare v1 v2 == 0)
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283

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)