/[svn]/runtime/eval.ml
ViewVC logotype

Diff of /runtime/eval.ml

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 70 by abate, Tue Jul 10 17:03:19 2007 UTC revision 375 by abate, Tue Jul 10 17:29:53 2007 UTC
# Line 1  Line 1 
1  open Value  open Value
2  open Run_dispatch  open Run_dispatch
3    open Ident
4    
5  module Env = Map.Make (struct type t = string let compare = compare end)  exception MultipleDeclaration of id
6    module Env = Map.Make (Ident.Id)
7  type env = t Env.t  type env = t Env.t
8    
9  let global_env = ref Env.empty  let global_env = State.ref "Eval.global_env" Env.empty
 let enter_global x v = global_env := Env.add x v !global_env  
10    
11    let enter_global x v =
12      if Env.mem x !global_env then
13        raise (MultipleDeclaration x);
14      global_env := Env.add x v !global_env
15    
 let exn_int_of = CDuceExn (Pair (Atom (Types.mk_atom "Invalid_argument"),  
                                  string "int_of"))  
16    
17    let exn_int_of = CDuceExn (Pair (
18                                 Atom (Atoms.mk_ascii "Invalid_argument"),
19                                 string_latin1 "int_of"))
20    
21    
22    let exn_load_file_utf8 = CDuceExn (Pair (
23                                 Atom (Atoms.mk_ascii "load_file_utf8"),
24                                 string_latin1 "File is not a valid UTF-8 stream"))
25    
 (* Evaluation of expressions *)  
26    
27    (* Evaluation of expressions *)
28    
29  let rec eval env e0 =  let rec eval env e0 =
30    match e0.Typed.exp_descr with    match e0.Typed.exp_descr with
# Line 26  Line 35 
35      | Typed.Apply (f,arg) ->  eval_apply (eval env f) (eval env arg)      | Typed.Apply (f,arg) ->  eval_apply (eval env f) (eval env arg)
36      | Typed.Abstraction a ->      | Typed.Abstraction a ->
37          let env =          let env =
38            List.fold_left            IdSet.fold
39              (fun accu x ->              (fun accu x ->
40                 try Env.add x (Env.find x env) accu                 try Env.add x (Env.find x env) accu
41                 with Not_found -> accu (* global *))                 with Not_found -> accu (* global *))
# Line 41  Line 50 
50          self          self
51  (* Optimizations:  (* Optimizations:
52         - for the non-recursive case, use eval_branches         - for the non-recursive case, use eval_branches
53         - for the recursive case, could cheat bt pathing self afterwards:         - for the recursive case, could cheat by patching self afterwards:
54                  (Obj.magic self).(1) <- ....                  (Obj.magic self).(1) <- ....
55  *)  *)
56      | Typed.RecordLitt r -> Record (List.map (fun (l,e) -> (l, eval env e)) r)      | Typed.RecordLitt r -> Record (LabelMap.map (eval env) r)
57      | Typed.Pair (e1,e2) -> Pair (eval env e1, eval env e2)      | Typed.Pair (e1,e2) -> Pair (eval env e1, eval env e2)
58        | Typed.Xml (e1,e2) -> Xml (eval env e1, eval env e2)
59      | Typed.Cst c -> const c      | Typed.Cst c -> const c
60      | Typed.Match (arg,brs) -> eval_branches env brs (eval env arg)      | Typed.Match (arg,brs) -> eval_branches env brs (eval env arg)
61      | Typed.Map (arg,brs) -> eval_map env brs (eval env arg)      | Typed.Map (false,arg,brs) -> eval_map env brs (eval env arg)
62        | Typed.Map (true,_,_) -> assert false
63        | Typed.Xtrans (arg,brs) -> eval_xtrans env brs (eval env arg)
64      | Typed.Op ("raise", [e]) -> raise (CDuceExn (eval env e))      | Typed.Op ("raise", [e]) -> raise (CDuceExn (eval env e))
65      | Typed.Try (arg,brs) ->      | Typed.Try (arg,brs) ->
66          (try eval env arg with CDuceExn v -> eval_branches env brs v)          (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      | Typed.Op ("flatten", [e]) -> eval_flatten (eval env e)      | Typed.Op ("flatten", [e]) -> eval_flatten (eval env e)
70      | Typed.Op ("@", [e1; e2]) -> eval_concat (eval env e1) (eval env e2)      | Typed.Op ("@", [e1; e2]) -> eval_concat (eval env e1) (eval env e2)
71      | Typed.Op ("+", [e1; e2]) -> eval_add (eval env e1) (eval env e2)      | Typed.Op ("+", [e1; e2]) -> eval_add (eval env e1) (eval env e2)
72      | Typed.Op ("*", [e1; e2]) -> eval_mul (eval env e1) (eval env e2)      | Typed.Op ("*", [e1; e2]) -> eval_mul (eval env e1) (eval env e2)
73      | Typed.Op ("-", [e1; e2]) -> eval_sub (eval env e1) (eval env e2)      | Typed.Op ("-", [e1; e2]) -> eval_sub (eval env e1) (eval env e2)
74      | Typed.Op ("/", [e1; e2]) -> eval_div (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)      | Typed.Op ("load_xml", [e]) -> eval_load_xml (eval env e)
77        | Typed.Op ("load_html", [e]) -> eval_load_html (eval env e)
78        | Typed.Op ("load_file", [e]) -> eval_load_file ~utf8:false (eval env e)
79        | Typed.Op ("load_file_utf8", [e]) -> eval_load_file ~utf8:true (eval env e)
80        | Typed.Op ("print_xml", [e]) -> Print_xml.print_xml ~utf8:false (eval env e)
81        | 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)      | 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        | Typed.Op ("dump_to_file", [e1; e2]) ->
87            eval_dump_to_file (eval env e1) (eval env e2)
88        | Typed.Op ("dump_to_file_utf8", [e1; e2]) ->
89            eval_dump_to_file_utf8 (eval env e1) (eval env e2)
90        | Typed.Op ("=",[e1; e2]) -> eval_equal (eval env e1) (eval env e2)
91        | Typed.Op ("<",[e1; e2]) -> eval_lt (eval env e1) (eval env e2)
92        | Typed.Op ("<=",[e1; e2]) -> eval_lte (eval env e1) (eval env e2)
93        | Typed.Op (">",[e1; e2]) -> eval_gt (eval env e1) (eval env e2)
94        | Typed.Op (">=",[e1; e2]) -> eval_gte (eval env e1) (eval env e2)
95      | Typed.Dot (e, l) -> eval_dot l (eval env e)      | Typed.Dot (e, l) -> eval_dot l (eval env e)
96      | Typed.DebugTyper t -> failwith "Evaluating a ! expression"      | Typed.RemoveField (e, l) -> eval_remove_field l (eval env e)
97      | Typed.Op (o,_) -> failwith ("Unknown operator " ^ o)      | Typed.Op (o,_) -> failwith ("Unknown operator " ^ o)
98    
99    
100  and eval_apply f arg = match f with  and eval_apply f arg = match f with
101    | Abstraction (_,clos) -> clos arg    | Abstraction (_,clos) -> clos arg
102    | _ -> assert false    | _ -> eval_concat f arg
103    
104  and eval_branches' env_ref brs arg =  and eval_branches' env_ref brs arg =
105    eval_branches !env_ref brs arg    eval_branches !env_ref brs arg
# Line 75  Line 107 
107  and eval_branches env brs arg =  and eval_branches env brs arg =
108    let (disp, rhs) = Typed.dispatcher brs in    let (disp, rhs) = Typed.dispatcher brs in
109    let (code, bindings) = run_dispatcher disp arg in    let (code, bindings) = run_dispatcher disp arg in
110    let (bind, e) = rhs.(code) in    match rhs.(code) with
111        | Patterns.Compile.Match (bind,e) ->
112    let env =    let env =
113      List.fold_left (fun env (x,i) ->      List.fold_left (fun env (x,i) ->
114                        if (i = -1) then Env.add x arg env                              if (i == -1) then Env.add x arg env
115                        else Env.add x bindings.(i) env) env bind in                              else Env.add x bindings.(i) env) env (IdMap.get bind) in
116    eval env e    eval env e
117        | Patterns.Compile.Fail -> Value.Absent
118    
119  and eval_let_decl env l =  and eval_let_decl env l =
120    let v = eval env l.Typed.let_body in    let v = eval env l.Typed.let_body in
121    let (disp,bind) = Typed.dispatcher_let_decl l in    let (disp,bind) = Typed.dispatcher_let_decl l in
122    let (_,bindings) = run_dispatcher disp v in    let (_,bindings) = run_dispatcher disp v in
123    List.map (fun (x,i) -> (x, if (i = -1) then v else bindings.(i))) bind    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  and eval_map env brs = function
126    | Pair (x,y) -> Pair (eval_branches env brs x, eval_map env brs y)    | Pair (x,y) ->
127    | String (_,_,_,_) as v -> eval_map env brs (normalize v)        let x = eval_branches env brs x in
128          Pair (x, eval_map env brs y)
129      | String_latin1 (_,_,_,_) | String_utf8 (_,_,_,_) as v ->
130          eval_map env brs (normalize v)
131    | q -> q    | q -> q
132    
133  and eval_flatten = function  and eval_flatten = function
134    | Pair (x,y) -> eval_concat x (eval_flatten y)    | Pair (x,y) -> eval_concat x (eval_flatten y)
135    | q -> q    | q -> q
136    
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      | String_latin1 (_,_,_,q) | String_utf8 (_,_,_,q) as v ->
142          if Types.Char.is_empty (brs.Typed.br_accept)
143          then eval_transform env brs q
144          else eval_transform env brs (normalize v)
145      | q -> q
146    
147    and eval_xtrans env brs = function
148      | String_utf8 (s,i,j,q) as v ->
149          if Types.Char.is_empty (brs.Typed.br_accept)
150          then String_utf8 (s,i,j, eval_xtrans env brs q)
151          else eval_xtrans env brs (normalize v)
152      | String_latin1 (s,i,j,q) as v ->
153          if Types.Char.is_empty (brs.Typed.br_accept)
154          then String_latin1 (s,i,j, eval_xtrans env brs q)
155          else eval_xtrans env brs (normalize v)
156      | Pair (x,y) ->
157          (match eval_branches env brs x with
158             | Absent ->
159                 let x = match x with
160                   | Xml (tag, Pair (attr, child)) ->
161                       let child = eval_xtrans env brs child in
162                       Xml (tag, Pair (attr, child))
163                   | Xml (_,_) -> assert false
164                   | x -> x in
165                 let y = eval_xtrans env brs y in
166                 Pair (x,y)
167             | x ->
168                 let y = eval_xtrans env brs y in
169                 eval_concat x y)
170      | q -> q
171    
172  and eval_concat l1 l2 = match l1 with  and eval_concat l1 l2 = match l1 with
173    | Pair (x,y) -> Pair (x, eval_concat y l2)    | Pair (x,y) -> Pair (x, eval_concat y l2)
174    | String (s,i,j,q) -> String (s,i,j, eval_concat q l2)    | String_latin1 (s,i,j,q) -> String_latin1 (s,i,j, eval_concat q l2)
175      | String_utf8 (s,i,j,q) -> String_utf8 (s,i,j, eval_concat q l2)
176    | q -> l2    | q -> l2
177    
178  and eval_dot l = function  and eval_dot l = function
179    | Record r -> List.assoc l r    | Record r -> LabelMap.assoc l r
180      | _ -> assert false
181    
182    and eval_remove_field l = function
183      | Record r -> Record (LabelMap.remove l r)
184    | _ -> assert false    | _ -> assert false
185    
186  and eval_add x y = match (x,y) with  and eval_add x y = match (x,y) with
187    | (Integer x, Integer y) -> Integer (Big_int.add_big_int x y)    | (Integer x, Integer y) -> Integer (Intervals.vadd x y)
188      | Record r1, Record r2 -> Record (LabelMap.merge (fun x y -> y) r1 r2)
189    | _ -> assert false    | _ -> assert false
190    
191  and eval_mul x y = match (x,y) with  and eval_mul x y = match (x,y) with
192    | (Integer x, Integer y) -> Integer (Big_int.mult_big_int x y)    | (Integer x, Integer y) -> Integer (Intervals.vmult x y)
193    | _ -> assert false    | _ -> assert false
194    
195  and eval_sub x y = match (x,y) with  and eval_sub x y = match (x,y) with
196    | (Integer x, Integer y) -> Integer (Big_int.sub_big_int x y)    | (Integer x, Integer y) -> Integer (Intervals.vsub x y)
197    | _ -> assert false    | _ -> assert false
198    
199  and eval_div x y = match (x,y) with  and eval_div x y = match (x,y) with
200    | (Integer x, Integer y) -> Integer (Big_int.div_big_int x y)    | (Integer x, Integer y) -> Integer (Intervals.vdiv x y)
201      | _ -> assert false
202    
203    and eval_mod x y = match (x,y) with
204      | (Integer x, Integer y) -> Integer (Intervals.vmod x y)
205    | _ -> assert false    | _ -> assert false
206    
207  and eval_load_xml e =  and eval_load_xml e =
208    Load_xml.run (get_string e)    Load_xml.load_xml (get_string_latin1 e)
209        (* Note: loading iso-8859-1 (even ASCII) files with utf-8 internal
210           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      let len = in_channel_length ic in
219      let s = String.create len in
220      really_input ic s 0 len;
221      close_in ic;
222      if utf8 then
223        if U.check s
224        then Value.string_utf8 (U.mk s)
225        else raise exn_load_file_utf8
226      else Value.string_latin1 s
227    
228  and eval_int_of e =  and eval_int_of e =
229    let s = get_string e in    let s = get_string_latin1 e in
230    try Integer (Big_int.big_int_of_string s)    try Integer (Intervals.mk s)
231    with Failure _ -> raise exn_int_of    with Failure _ -> raise exn_int_of
232    
233  and get_string e =  and eval_atom_of e =
234    let rec compute_len accu = function    let (s,_) = get_string_utf8 e in (* TODO: check that s is a correct Name wrt XML *)
235      | Pair (_,y) -> compute_len (accu + 1) y    Atom (Atoms.mk s)
236      | String (i,j,_,y) -> compute_len (accu + j - i) y  
237      | _ -> accu in  and eval_print v =
238    let rec fill pos s = function    Location.protect_op "print";
239      | Pair (Char x,y) -> s.[pos] <- Chars.Unichar.to_char x; fill (pos + 1) s y    print_string (get_string_latin1 v);
240      | String (i,j,src,y) ->    flush stdout;
241          String.blit src i s pos (j - i); fill (pos + j - i) s y    Value.nil
242      | _ -> s in  
243    fill 0 (String.create (compute_len 0 e)) e  and eval_dump_to_file f v =
244      Location.protect_op "dump_to_file";
245      let oc = open_out (get_string_latin1 f) in
246      output_string oc (get_string_latin1 v);
247      close_out oc;
248      Value.nil
249    and eval_dump_to_file_utf8 f v =
250      Location.protect_op "dump_to_file_utf8";
251      let oc = open_out (get_string_latin1 f) in
252      let (v,_) = get_string_utf8 v in
253      output_string oc (U.get_str v);
254      close_out oc;
255      Value.nil
256    
257    
258    and eval_string_of v =
259      let b = Buffer.create 16 in
260      let ppf = Format.formatter_of_buffer b in
261      Value.print ppf v;
262      Format.pp_print_flush ppf ();
263      string_latin1 (Buffer.contents b)
264    
265    and eval_equal v1 v2 =
266      let c = Value.compare v1 v2 in
267      Value.vbool (Value.compare v1 v2 == 0)
268    
269    and eval_lt v1 v2 =
270      let c = Value.compare v1 v2 in
271      Value.vbool (Value.compare v1 v2 < 0)
272    
273    and eval_lte v1 v2 =
274      let c = Value.compare v1 v2 in
275      Value.vbool (Value.compare v1 v2 <= 0)
276    
277    and eval_gt v1 v2 =
278      let c = Value.compare v1 v2 in
279      Value.vbool (Value.compare v1 v2 > 0)
280    
281    and eval_gte v1 v2 =
282      let c = Value.compare v1 v2 in
283      Value.vbool (Value.compare v1 v2 >= 0)
Legend:
Removed from v.70  
changed lines
  Added in v.375
CVS Admin">CVS Admin
 ViewVC Help
Powered by ViewVC 1.1.5