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 ("atom_of", [e]) -> eval_atom_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_atom_of e =
  let s = get_string_latin1 e in (* TODO: UTF-8 *)
  (* TODO: check that s is a correct Name wrt XML *)
  Atom (Atoms.mk s)
  
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 ("atom_of", [e]) -> eval_atom_of (eval env e)
76	\| Typed.Op ("string_of", [e]) -> eval_string_of (eval env e)
77	\| Typed.Op ("dump_to_file", [e1; e2]) ->
78	eval_dump_to_file (eval env e1) (eval env e2)
79	\| Typed.Op ("=",[e1; e2]) -> eval_equal (eval env e1) (eval env e2)
80	\| Typed.Op ("<",[e1; e2]) -> eval_lt (eval env e1) (eval env e2)
81	\| Typed.Op ("<=",[e1; e2]) -> eval_lte (eval env e1) (eval env e2)
82	\| Typed.Op (">",[e1; e2]) -> eval_gt (eval env e1) (eval env e2)
83	\| Typed.Op (">=",[e1; e2]) -> eval_gte (eval env e1) (eval env e2)
84	\| Typed.Dot (e, l) -> eval_dot l (eval env e)
85	\| Typed.RemoveField (e, l) -> eval_remove_field l (eval env e)
86	\| Typed.MatchFail -> raise EMatchFail
87	\| Typed.Op (o,_) -> failwith ("Unknown operator " ^ o)
88
89
90	and eval_apply f arg = match f with
91	\| Abstraction (_,clos) -> clos arg
92	\| _ -> eval_concat f arg
93
94	and eval_branches' env_ref brs arg =
95	eval_branches !env_ref brs arg
96
97	and eval_branches env brs arg =
98	let (disp, rhs) = Typed.dispatcher brs in
99	let (code, bindings) = run_dispatcher disp arg in
100	let (bind, e) = rhs.(code) in
101	let env =
102	List.fold_left (fun env (x,i) ->
103	if (i = -1) then Env.add x arg env
104	else Env.add x bindings.(i) env) env (IdMap.get bind) in
105	eval env e
106
107	and eval_let_decl env l =
108	let v = eval env l.Typed.let_body in
109	let (disp,bind) = Typed.dispatcher_let_decl l in
110	let (_,bindings) = run_dispatcher disp v in
111	List.map (fun (x,i) -> (x, if (i = -1) then v else bindings.(i))) (IdMap.get bind)
112
113	and eval_map env brs = function
114	\| Pair (x,y) ->
115	let x = eval_branches env brs x in
116	Pair (x, eval_map env brs y)
117	\| String_latin1 (_,_,_,_) \| String_utf8 (_,_,_,_) as v -> eval_map env brs (normalize v)
118	\| q -> q
119
120	and eval_flatten = function
121	\| Pair (x,y) -> eval_concat x (eval_flatten y)
122	\| q -> q
123
124	and eval_transform env brs = function
125	\| Pair (x,y) ->
126	let x = eval_branches env brs x in
127	eval_concat x (eval_transform env brs y)
128	\| String_latin1 (_,_,_,_) \| String_utf8 (_,_,_,_) as v -> eval_transform env brs (normalize v)
129	\| q -> q
130
131	and eval_ttree env brs = function
132	\| Pair (x,y) ->
133	let y = eval_ttree env brs y in (* Beware of evaluation order !! Reverse it ? *)
134	(try
135	let x = eval_branches env brs x in
136	(* TODO: avoid raising exceptions (for each character/element !) *)
137	eval_concat x y
138	with EMatchFail ->
139	let x = match x with
140	\| Xml (tag, Pair (attr, child)) ->
141	let child = eval_ttree env brs child in
142	Xml (tag, Pair (attr, child))
143	\| Xml (_,_) -> assert false
144	\| x -> x in
145	Pair (x,y))
146	\| String_latin1 (_,_,_,_) \| String_utf8 (_,_,_,_) as v -> eval_ttree env brs (normalize v)
147	(* TODO: optimize for strings, to avoid decomposing compound String values *)
148	\| q -> q
149
150	and eval_concat l1 l2 = match l1 with
151	\| Pair (x,y) -> Pair (x, eval_concat y l2)
152	\| String_latin1 (s,i,j,q) -> String_latin1 (s,i,j, eval_concat q l2)
153	\| String_utf8 (s,i,j,q) -> String_utf8 (s,i,j, eval_concat q l2)
154	\| q -> l2
155
156	and eval_dot l = function
157	\| Record r -> LabelMap.assoc l r
158	\| _ -> assert false
159
160	and eval_remove_field l = function
161	\| Record r -> Record (LabelMap.remove l r)
162	\| _ -> assert false
163
164	and eval_add x y = match (x,y) with
165	\| (Integer x, Integer y) -> Integer (Intervals.vadd x y)
166	\| Record r1, Record r2 -> Record (LabelMap.merge (fun x y -> y) r1 r2)
167	\| _ -> assert false
168
169	and eval_mul x y = match (x,y) with
170	\| (Integer x, Integer y) -> Integer (Intervals.vmult x y)
171	\| _ -> assert false
172
173	and eval_sub x y = match (x,y) with
174	\| (Integer x, Integer y) -> Integer (Intervals.vsub x y)
175	\| _ -> assert false
176
177	and eval_div x y = match (x,y) with
178	\| (Integer x, Integer y) -> Integer (Intervals.vdiv x y)
179	\| _ -> assert false
180
181	and eval_mod x y = match (x,y) with
182	\| (Integer x, Integer y) -> Integer (Intervals.vmod x y)
183	\| _ -> assert false
184
185	and eval_load_xml e =
186	Load_xml.load_xml (get_string_latin1 e)
187
188	and eval_load_html e =
189	Load_xml.load_html (get_string_latin1 e)
190
191	and eval_load_file e =
192	Location.protect_op "load_file";
193	let ic = open_in (get_string_latin1 e) in
194	let len = in_channel_length ic in
195	let s = String.create len in
196	really_input ic s 0 len;
197	close_in ic;
198	Value.string_latin1 s
199
200	and eval_int_of e =
201	let s = get_string_latin1 e in
202	try Integer (Intervals.mk s)
203	with Failure _ -> raise exn_int_of
204
205	and eval_atom_of e =
206	let s = get_string_latin1 e in (* TODO: UTF-8 *)
207	(* TODO: check that s is a correct Name wrt XML *)
208	Atom (Atoms.mk s)
209
210	and eval_print_xml v =
211	string_latin1 (Print_xml.string_of_xml v)
212
213	and eval_print v =
214	Location.protect_op "print";
215	print_string (get_string_latin1 v);
216	flush stdout;
217	Value.nil
218
219	and eval_dump_to_file f v =
220	Location.protect_op "dump_to_file";
221	let oc = open_out (get_string_latin1 f) in
222	output_string oc (get_string_latin1 v);
223	close_out oc;
224	Value.nil
225
226
227	and eval_string_of v =
228	let b = Buffer.create 16 in
229	let ppf = Format.formatter_of_buffer b in
230	Value.print ppf v;
231	Format.pp_print_flush ppf ();
232	string_latin1 (Buffer.contents b)
233
234	and eval_equal v1 v2 =
235	let c = Value.compare v1 v2 in
236	Value.vbool (Value.compare v1 v2 = 0)
237
238	and eval_lt v1 v2 =
239	let c = Value.compare v1 v2 in
240	Value.vbool (Value.compare v1 v2 < 0)
241
242	and eval_lte v1 v2 =
243	let c = Value.compare v1 v2 in
244	Value.vbool (Value.compare v1 v2 <= 0)
245
246	and eval_gt v1 v2 =
247	let c = Value.compare v1 v2 in
248	Value.vbool (Value.compare v1 v2 > 0)
249
250	and eval_gte v1 v2 =
251	let c = Value.compare v1 v2 in
252	Value.vbool (Value.compare v1 v2 >= 0)