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

5
module Env = Map.Make (Ident.Id)
6
7
type env = t Env.t

8
let global_env = State.ref "Eval.global_env" Env.empty
9
10
11
let enter_global x v = global_env := Env.add x v !global_env


12
let exn_int_of = CDuceExn (Pair (
13
			     Atom (Atoms.mk "Invalid_argument"),
14
			     string "int_of"))
15
16
17
18
19
20




(* Evaluation of expressions *)

21
exception EMatchFail
22
23
24
25
26
27
28
29
30
31

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 = 
32
	  IdSet.fold
33
34
35
36
37
38
39
40
41
42
43
44
45
46
	    (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
47
       - for the recursive case, could cheat by patching self afterwards:
48
49
                (Obj.magic self).(1) <- ....
*)
50
    | Typed.RecordLitt r -> Record (LabelMap.map (eval env) r)
51
    | Typed.Pair (e1,e2) -> Pair (eval env e1, eval env e2)
52
    | Typed.Xml (e1,e2) -> Xml (eval env e1, eval env e2)
53
54
55
    | Typed.Cst c -> const c
    | Typed.Match (arg,brs) -> eval_branches env brs (eval env arg)
    | Typed.Map (arg,brs) -> eval_map env brs (eval env arg)
56
    | Typed.Ttree (arg,brs) -> eval_ttree env brs (eval env arg)
57
58
59
    | 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)
60
61
    | Typed.Op ("flatten", [{Typed.exp_descr=Typed.Map (arg,brs)}]) -> 
	eval_transform env brs (eval env arg) 
62
63
64
65
66
67
    | 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)
68
    | Typed.Op ("mod", [e1; e2]) -> eval_mod (eval env e1) (eval env e2)
69
    | Typed.Op ("load_xml", [e]) -> eval_load_xml (eval env e)
70
    | Typed.Op ("load_html", [e]) -> eval_load_html (eval env e)
71
    | Typed.Op ("load_file", [e]) -> eval_load_file (eval env e)
72
    | Typed.Op ("print_xml", [e]) -> eval_print_xml (eval env e)
73
    | Typed.Op ("print", [e]) -> eval_print (eval env e)
74
    | Typed.Op ("int_of", [e]) -> eval_int_of (eval env e)
75
    | Typed.Op ("string_of", [e]) -> eval_string_of (eval env e)
76
77
    | Typed.Op ("dump_to_file", [e1; e2]) -> 
	eval_dump_to_file (eval env e1) (eval env e2)
78
79
80
81
82
    | 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)
83
    | Typed.Dot (e, l) -> eval_dot l (eval env e)
84
    | Typed.RemoveField (e, l) -> eval_remove_field l (eval env e)
85
    | Typed.MatchFail -> raise EMatchFail
86
87
88
89
90
    | Typed.Op (o,_) -> failwith ("Unknown operator " ^ o)


and eval_apply f arg = match f with
  | Abstraction (_,clos) -> clos arg
91
  | _ -> eval_concat f arg
92
93
94
95
96
97
98
99
100
101

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
  let (bind, e) = rhs.(code) in
  let env = 
    List.fold_left (fun env (x,i) -> 
102
103
		  if (i = -1) then Env.add x arg env 
		  else Env.add x bindings.(i) env) env (IdMap.get bind) in
104
105
106
107
108
109
  eval env e

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

and eval_map env brs = function
113
114
115
  | Pair (x,y) -> 
      let x = eval_branches env brs x in
      Pair (x, eval_map env brs y)
116
117
118
119
120
121
122
  | String (_,_,_,_) as v -> eval_map env brs (normalize v)
  | q -> q
  
and eval_flatten = function
  | Pair (x,y) -> eval_concat x (eval_flatten y)
  | q -> q

123
and eval_transform env brs = function
124
125
126
  | Pair (x,y) -> 
      let x = eval_branches env brs x in
      eval_concat x (eval_transform env brs y)
127
128
129
  | String (_,_,_,_) as v -> eval_transform env brs (normalize v)
  | q -> q

130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
and eval_ttree env brs = function
  | Pair (x,y) -> 
      let y = eval_ttree env brs y in (* Beware of evaluation order !! Reverse it ? *)
      (try
	 let x = eval_branches env brs x in
(* TODO: avoid raising exceptions (for each character/element !) *)
	 eval_concat x y
       with EMatchFail ->
	 let x = match x with
	   | Xml (tag, Pair (attr, child)) -> 
	       let child = eval_ttree env brs child in
	       Xml (tag, Pair (attr, child))
	   | Xml (_,_) -> assert false
	   | x -> x in
	 Pair (x,y))
  | String (_,_,_,_) as v -> eval_ttree env brs (normalize v)
(* TODO: optimize for strings, to avoid decomposing compound String values *)
  | q -> q

149
150
151
152
153
154
and eval_concat l1 l2 = match l1 with
  | Pair (x,y) -> Pair (x, eval_concat y l2)
  | String (s,i,j,q) -> String (s,i,j, eval_concat q l2)
  | q -> l2

and eval_dot l = function
155
  | Record r -> LabelMap.assoc l r
156
157
  | _ -> assert false

158
159
160
161
and eval_remove_field l = function
  | Record r -> Record (LabelMap.remove l r)
  | _ -> assert false

162
and eval_add x y = match (x,y) with
163
  | (Integer x, Integer y) -> Integer (Intervals.vadd x y)
164
  | Record r1, Record r2 -> Record (LabelMap.merge (fun x y -> y) r1 r2)
165
166
167
  | _ -> assert false

and eval_mul x y = match (x,y) with
168
  | (Integer x, Integer y) -> Integer (Intervals.vmult x y)
169
170
171
  | _ -> assert false

and eval_sub x y = match (x,y) with
172
  | (Integer x, Integer y) -> Integer (Intervals.vsub x y)
173
174
175
  | _ -> assert false

and eval_div x y = match (x,y) with
176
  | (Integer x, Integer y) -> Integer (Intervals.vdiv x y)
177
178
  | _ -> assert false

179
and eval_mod x y = match (x,y) with
180
  | (Integer x, Integer y) -> Integer (Intervals.vmod x y)
181
182
  | _ -> assert false

183
and eval_load_xml e =
184
185
186
187
  Load_xml.load_xml (get_string e)

and eval_load_html e =
  Load_xml.load_html (get_string e)
188

189
190
191
192
193
194
195
196
197
and eval_load_file e =
  Location.protect_op "load_file";
  let ic = open_in (get_string e) in
  let len = in_channel_length ic in
  let s = String.create len in
  really_input ic s 0 len;
  close_in ic;
  Value.string s

198
199
and eval_int_of e =
  let s = get_string e in
200
  try Integer (Intervals.mk s)
201
202
  with Failure _ -> raise exn_int_of
  
203
204
205
and eval_print_xml v =
  string (Print_xml.string_of_xml v)

206
and eval_print v =
207
  Location.protect_op "print";
208
209
  print_string (get_string v);
  flush stdout;
210
211
212
213
214
215
216
217
218
  Value.nil

and eval_dump_to_file f v =
  Location.protect_op "dump_to_file";
  let oc = open_out (get_string f) in
  output_string oc (get_string v);
  close_out oc;
  Value.nil

219
220
221
222
223
224
225
226

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 ();
  string (Buffer.contents b)
    
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
and eval_equal v1 v2 =
  let c = Value.compare v1 v2 in
  Value.vbool (Value.compare v1 v2 = 0)

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)