viewcvs.cgi/runtime/eval.ml

open Value
open Run_dispatch
open Ident

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

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


let exn_int_of = CDuceExn (Pair (
                             Atom (Atoms.mk "Invalid_argument"),
                             string_latin1 "int_of"))


(* Evaluation of expressions *)

exception EMatchFail

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 = 
          IdSet.fold
            (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
       - for the recursive case, could cheat by patching self afterwards:
                (Obj.magic self).(1) <- ....
*)
    | Typed.RecordLitt r -> Record (LabelMap.map (eval env) r)
    | Typed.Pair (e1,e2) -> Pair (eval env e1, eval env e2)
    | Typed.Xml (e1,e2) -> Xml (eval env e1, eval env e2)
    | 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)
    | Typed.Ttree (arg,brs) -> eval_ttree env brs (eval env arg)
    | 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)
    | Typed.Op ("flatten", [{Typed.exp_descr=Typed.Map (arg,brs)}]) -> 
        eval_transform env brs (eval env arg) 
    | 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)
    | Typed.Op ("mod", [e1; e2]) -> eval_mod (eval env e1) (eval env e2)
    | Typed.Op ("load_xml", [e]) -> eval_load_xml (eval env e)
    | Typed.Op ("load_html", [e]) -> eval_load_html (eval env e)
    | Typed.Op ("load_file", [e]) -> eval_load_file (eval env e)
    | Typed.Op ("print_xml", [e]) -> eval_print_xml (eval env e)
    | Typed.Op ("print", [e]) -> eval_print (eval env e)
    | Typed.Op ("int_of", [e]) -> eval_int_of (eval env e)
    | Typed.Op ("string_of", [e]) -> eval_string_of (eval env e)
    | Typed.Op ("dump_to_file", [e1; e2]) -> 
        eval_dump_to_file (eval env e1) (eval env e2)
    | 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)
    | Typed.Dot (e, l) -> eval_dot l (eval env e)
    | Typed.RemoveField (e, l) -> eval_remove_field l (eval env e)
    | Typed.MatchFail -> raise EMatchFail
    | Typed.Op (o,_) -> failwith ("Unknown operator " ^ o)


and eval_apply f arg = match f with
  | Abstraction (_,clos) -> clos arg
  | _ -> eval_concat f arg

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) -> 
                  if (i = -1) then Env.add x arg env 
                  else Env.add x bindings.(i) env) env (IdMap.get bind) in
  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
  List.map (fun (x,i) -> (x, if (i = -1) then v else bindings.(i))) (IdMap.get bind)

and eval_map env brs = function
  | Pair (x,y) -> 
      let x = eval_branches env brs x in
      Pair (x, eval_map env brs y)
  | String_latin1 (_,_,_,_) | String_utf8 (_,_,_,_) 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

and eval_transform env brs = function
  | Pair (x,y) -> 
      let x = eval_branches env brs x in
      eval_concat x (eval_transform env brs y)
  | String_latin1 (_,_,_,_) | String_utf8 (_,_,_,_) as v -> eval_transform env brs (normalize v)
  | q -> q

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_latin1 (_,_,_,_) | String_utf8 (_,_,_,_) as v -> eval_ttree env brs (normalize v)
(* TODO: optimize for strings, to avoid decomposing compound String values *)
  | q -> q

and eval_concat l1 l2 = match l1 with
  | Pair (x,y) -> Pair (x, eval_concat y l2)
  | 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)
  | q -> l2

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

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

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

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

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

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

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

and eval_load_xml e =
  Load_xml.load_xml (get_string_latin1 e)

and eval_load_html e =
  Load_xml.load_html (get_string_latin1 e)

and eval_load_file e =
  Location.protect_op "load_file";
  let ic = open_in (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;
  Value.string_latin1 s

and eval_int_of e =
  let s = get_string_latin1 e in
  try Integer (Intervals.mk s)
  with Failure _ -> raise exn_int_of
  
and eval_print_xml v =
  string_latin1 (Print_xml.string_of_xml v)

and eval_print v =
  Location.protect_op "print";
  print_string (get_string_latin1 v);
  flush stdout;
  Value.nil

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


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_latin1 (Buffer.contents b)
    
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)
1	open Value
2	open Run_dispatch
3	open Ident
4
5	module Env = Map.Make (Ident.Id)
6	type env = t Env.t
7
8	let global_env = State.ref "Eval.global_env" Env.empty
9	let enter_global x v = global_env := Env.add x v !global_env
10
11
12	let exn_int_of = CDuceExn (Pair (
13	Atom (Atoms.mk "Invalid_argument"),
14	string_latin1 "int_of"))
15
16
17
18
19	(* Evaluation of expressions *)
20
21	exception EMatchFail
22
23	let rec eval env e0 =
24	match e0.Typed.exp_descr with
25	\| Typed.Forget (e,_) -> eval env e
26	\| Typed.Var s ->
27	(try Env.find s env
28	with Not_found -> Env.find s !global_env)
29	\| Typed.Apply (f,arg) -> eval_apply (eval env f) (eval env arg)
30	\| Typed.Abstraction a ->
31	let env =
32	IdSet.fold
33	(fun accu x ->
34	try Env.add x (Env.find x env) accu
35	with Not_found -> accu (* global *))
36	Env.empty a.Typed.fun_fv in
37	let env_ref = ref env in
38	let rec self = Abstraction (a.Typed.fun_iface,
39	eval_branches' env_ref a.Typed.fun_body) in
40	(match a.Typed.fun_name with
41	\| None -> ()
42	\| Some f -> env_ref := Env.add f self env;
43	);
44	self
45	(* Optimizations:
46	- for the non-recursive case, use eval_branches
47	- for the recursive case, could cheat by patching self afterwards:
48	(Obj.magic self).(1) <- ....
49	*)
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	\| Typed.Cst c -> const c
54	\| Typed.Match (arg,brs) -> eval_branches env brs (eval env arg)
55	\| Typed.Map (arg,brs) -> eval_map env brs (eval env arg)
56	\| Typed.Ttree (arg,brs) -> eval_ttree env brs (eval env arg)
57	\| Typed.Op ("raise", [e]) -> raise (CDuceExn (eval env e))
58	\| Typed.Try (arg,brs) ->
59	(try eval env arg with CDuceExn v -> eval_branches env brs v)
60	\| Typed.Op ("flatten", [{Typed.exp_descr=Typed.Map (arg,brs)}]) ->
61	eval_transform env brs (eval env arg)
62	\| Typed.Op ("flatten", [e]) -> eval_flatten (eval env e)
63	\| Typed.Op ("@", [e1; e2]) -> eval_concat (eval env e1) (eval env e2)
64	\| Typed.Op ("+", [e1; e2]) -> eval_add (eval env e1) (eval env e2)
65	\| Typed.Op ("*", [e1; e2]) -> eval_mul (eval env e1) (eval env e2)
66	\| Typed.Op ("-", [e1; e2]) -> eval_sub (eval env e1) (eval env e2)
67	\| 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	\| Typed.Op ("dump_to_file", [e1; e2]) ->
77	eval_dump_to_file (eval env e1) (eval env e2)
78	\| Typed.Op ("=",[e1; e2]) -> eval_equal (eval env e1) (eval env e2)
79	\| Typed.Op ("<",[e1; e2]) -> eval_lt (eval env e1) (eval env e2)
80	\| Typed.Op ("<=",[e1; e2]) -> eval_lte (eval env e1) (eval env e2)
81	\| Typed.Op (">",[e1; e2]) -> eval_gt (eval env e1) (eval env e2)
82	\| 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	\| Typed.Op (o,_) -> failwith ("Unknown operator " ^ o)
87
88
89	and eval_apply f arg = match f with
90	\| Abstraction (_,clos) -> clos arg
91	\| _ -> eval_concat f arg
92
93	and eval_branches' env_ref brs arg =
94	eval_branches !env_ref brs arg
95
96	and eval_branches env brs arg =
97	let (disp, rhs) = Typed.dispatcher brs in
98	let (code, bindings) = run_dispatcher disp arg in
99	let (bind, e) = rhs.(code) in
100	let env =
101	List.fold_left (fun env (x,i) ->
102	if (i = -1) then Env.add x arg env
103	else Env.add x bindings.(i) env) env (IdMap.get bind) in
104	eval env e
105
106	and eval_let_decl env l =
107	let v = eval env l.Typed.let_body in
108	let (disp,bind) = Typed.dispatcher_let_decl l in
109	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	\| Pair (x,y) ->
114	let x = eval_branches env brs x in
115	Pair (x, eval_map env brs y)
116	\| String_latin1 (_,_,_,_) \| String_utf8 (_,_,_,_) as v -> eval_map env brs (normalize v)
117	\| q -> q
118
119	and eval_flatten = function
120	\| Pair (x,y) -> eval_concat x (eval_flatten y)
121	\| q -> q
122
123	and eval_transform env brs = function
124	\| Pair (x,y) ->
125	let x = eval_branches env brs x in
126	eval_concat x (eval_transform env brs y)
127	\| String_latin1 (_,_,_,_) \| String_utf8 (_,_,_,_) as v -> eval_transform env brs (normalize v)
128	\| q -> q
129
130	and eval_ttree env brs = function
131	\| Pair (x,y) ->
132	let y = eval_ttree env brs y in (* Beware of evaluation order !! Reverse it ? *)
133	(try
134	let x = eval_branches env brs x in
135	(* TODO: avoid raising exceptions (for each character/element !) *)
136	eval_concat x y
137	with EMatchFail ->
138	let x = match x with
139	\| Xml (tag, Pair (attr, child)) ->
140	let child = eval_ttree env brs child in
141	Xml (tag, Pair (attr, child))
142	\| Xml (_,_) -> assert false
143	\| x -> x in
144	Pair (x,y))
145	\| String_latin1 (_,_,_,_) \| String_utf8 (_,_,_,_) as v -> eval_ttree env brs (normalize v)
146	(* TODO: optimize for strings, to avoid decomposing compound String values *)
147	\| q -> q
148
149	and eval_concat l1 l2 = match l1 with
150	\| Pair (x,y) -> Pair (x, eval_concat y l2)
151	\| String_latin1 (s,i,j,q) -> String_latin1 (s,i,j, eval_concat q l2)
152	\| String_utf8 (s,i,j,q) -> String_utf8 (s,i,j, eval_concat q l2)
153	\| q -> l2
154
155	and eval_dot l = function
156	\| Record r -> LabelMap.assoc l r
157	\| _ -> assert false
158
159	and eval_remove_field l = function
160	\| Record r -> Record (LabelMap.remove l r)
161	\| _ -> assert false
162
163	and eval_add x y = match (x,y) with
164	\| (Integer x, Integer y) -> Integer (Intervals.vadd x y)
165	\| Record r1, Record r2 -> Record (LabelMap.merge (fun x y -> y) r1 r2)
166	\| _ -> assert false
167
168	and eval_mul x y = match (x,y) with
169	\| (Integer x, Integer y) -> Integer (Intervals.vmult x y)
170	\| _ -> assert false
171
172	and eval_sub x y = match (x,y) with
173	\| (Integer x, Integer y) -> Integer (Intervals.vsub x y)
174	\| _ -> assert false
175
176	and eval_div x y = match (x,y) with
177	\| (Integer x, Integer y) -> Integer (Intervals.vdiv x y)
178	\| _ -> assert false
179
180	and eval_mod x y = match (x,y) with
181	\| (Integer x, Integer y) -> Integer (Intervals.vmod x y)
182	\| _ -> assert false
183
184	and eval_load_xml e =
185	Load_xml.load_xml (get_string_latin1 e)
186
187	and eval_load_html e =
188	Load_xml.load_html (get_string_latin1 e)
189
190	and eval_load_file e =
191	Location.protect_op "load_file";
192	let ic = open_in (get_string_latin1 e) in
193	let len = in_channel_length ic in
194	let s = String.create len in
195	really_input ic s 0 len;
196	close_in ic;
197	Value.string_latin1 s
198
199	and eval_int_of e =
200	let s = get_string_latin1 e in
201	try Integer (Intervals.mk s)
202	with Failure _ -> raise exn_int_of
203
204	and eval_print_xml v =
205	string_latin1 (Print_xml.string_of_xml v)
206
207	and eval_print v =
208	Location.protect_op "print";
209	print_string (get_string_latin1 v);
210	flush stdout;
211	Value.nil
212
213	and eval_dump_to_file f v =
214	Location.protect_op "dump_to_file";
215	let oc = open_out (get_string_latin1 f) in
216	output_string oc (get_string_latin1 v);
217	close_out oc;
218	Value.nil
219
220
221	and eval_string_of v =
222	let b = Buffer.create 16 in
223	let ppf = Format.formatter_of_buffer b in
224	Value.print ppf v;
225	Format.pp_print_flush ppf ();
226	string_latin1 (Buffer.contents b)
227
228	and eval_equal v1 v2 =
229	let c = Value.compare v1 v2 in
230	Value.vbool (Value.compare v1 v2 = 0)
231
232	and eval_lt v1 v2 =
233	let c = Value.compare v1 v2 in
234	Value.vbool (Value.compare v1 v2 < 0)
235
236	and eval_lte v1 v2 =
237	let c = Value.compare v1 v2 in
238	Value.vbool (Value.compare v1 v2 <= 0)
239
240	and eval_gt v1 v2 =
241	let c = Value.compare v1 v2 in
242	Value.vbool (Value.compare v1 v2 > 0)
243
244	and eval_gte v1 v2 =
245	let c = Value.compare v1 v2 in
246	Value.vbool (Value.compare v1 v2 >= 0)