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

Diff of /runtime/eval.ml

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

revision 923 by abate, Tue Jul 10 18:07:57 2007 UTC revision 924 by abate, Tue Jul 10 18:11:42 2007 UTC
# Line 1  Line 1 
1  open Value  open Value
2  open Run_dispatch  open Run_dispatch
3  open Ident  open Ident
4    open Lambda
 type env = t Env.t  
   
 let empty = Env.empty  
5    
6  let eval_unary_op = ref (fun _ -> assert false)  let eval_unary_op = ref (fun _ -> assert false)
7  let eval_binary_op = ref (fun _ _ -> assert false)  let eval_binary_op = ref (fun _ _ -> assert false)
8    
 let enter_value = Env.add  
 let enter_values l env =  
   List.fold_left (fun env (x,v) -> Env.add x v env) env l  
   
 let find_value = Env.find  
   
9  (* To write tail-recursive map-like iteration *)  (* To write tail-recursive map-like iteration *)
10    
11  let make_accu () = Pair(nil,Absent)  let make_accu () = Value.Pair(nil,Absent)
12  let get_accu a = snd (Obj.magic a)  let get_accu a = snd (Obj.magic a)
13  let map f v = let acc0 = make_accu () in set_cdr (f acc0 v) nil; get_accu acc0  let map f v = let acc0 = make_accu () in set_cdr (f acc0 v) nil; get_accu acc0
14    
 (* Evaluation of expressions *)  
   
 let from_comp_unit = ref (fun cu i -> assert false)  
 let eval_apply = ref (fun f x -> assert false)  
   
 let rec eval env e0 = match e0.Typed.exp_descr with  
   | Typed.Forget (e,_) -> eval env e  
   | Typed.Var s -> (match Env.find s env with Value.Delayed x -> !x | x -> x)  
   | Typed.ExtVar (cu,i) -> !from_comp_unit cu i  
   | Typed.Apply (f,arg) ->  !eval_apply (eval env f) (eval env arg)  
   | Typed.Abstraction a -> eval_abstraction env a  
   | Typed.RecordLitt r -> Record (LabelMap.map (eval env) r)  
   | Typed.Pair (e1,e2) -> Pair (eval env e1, eval env e2)  
   | Typed.Xml (e1, { Typed.exp_descr = Typed.Pair (e2,e3) }) ->  
       Xml (eval env e1, eval env e2, eval env e3)  
   | Typed.Xml (_,_) -> assert false  
   | Typed.Cst c -> const c  
   | Typed.String (i,j,s,e) -> String_utf8 (i,j,s, eval env e)  
   | Typed.Match (arg,brs) -> eval_branches env brs (eval env arg)  
   | Typed.Map (arg,brs) -> eval_map env brs (eval env arg)  
   | Typed.Xtrans (arg,brs) -> eval_xtrans env brs (eval env arg)  
   | Typed.Try (arg,brs) -> eval_try env arg brs  
   | Typed.Transform (arg,brs) -> eval_transform env brs (eval env arg)  
   | Typed.Dot (e, l) -> eval_dot l (eval env e)  
   | Typed.RemoveField (e, l) -> eval_remove_field l (eval env e)  
   | Typed.UnaryOp (op,e) -> !eval_unary_op op (eval env e)  
   | Typed.BinaryOp (op,e1,e2) -> !eval_binary_op op (eval env e1) (eval env e2)  
   | Typed.Validate (e, kind, schema, name) ->  
       eval_validate env e kind schema name  
   | Typed.Ref (e,t) -> eval_ref env e t  
   
   
 and eval_ref env e t=  
   let r = ref (eval env e) in  
   let get =  
     Abstraction ([Sequence.nil_type, Types.descr t], fun _ -> !r)  
   and set =  
     Abstraction  
       ([Types.descr t, Sequence.nil_type], fun x -> r := x; nil) in  
   Record (Builtin_defs.mk_ref ~get ~set)  
   
 and eval_validate env e kind schema_name name =  
   let schema = Typer.get_schema schema_name in  
   try  
     let validate =  
       match Schema_common.get_component kind name schema with  
       | Schema_types.Type x -> Schema_validator.validate_type x schema  
       | Schema_types.Element x -> Schema_validator.validate_element x schema  
       | Schema_types.Attribute x ->  
           assert false  (* TODO see schema/schema_validator.mli *)  
 (*           Schema_validator.validate_attribute x schema *)  
       | Schema_types.Attribute_group x ->  
           Schema_validator.validate_attribute_group x schema  
       | Schema_types.Model_group x ->  
           Schema_validator.validate_model_group x schema  
     in  
     validate (eval env e)  
   with Schema_common.XSI_validation_error msg ->  
     failwith' ("Schema validation failure: " ^ msg)  
   
 and eval_try env arg brs =  
   try eval env arg  
   with (CDuceExn v) as exn ->  
     match eval_branches env brs v with  
       | Value.Absent -> raise exn  
       | x -> x  
   
 and eval_abstraction env a =  
   let env =  
     IdSet.fold  
       (fun accu x -> Env.add x (Env.find x env) accu)  
       Env.empty a.Typed.fun_fv in  
   match a.Typed.fun_name with  
     | None ->  
         Abstraction (a.Typed.fun_iface, eval_branches env a.Typed.fun_body)  
     | Some f ->  
         let self = ref Value.Absent in  
         let env = Env.add f (Value.Delayed self) env in  
         let a =  
           Abstraction  
             (a.Typed.fun_iface, eval_branches env a.Typed.fun_body) in  
         self := a;  
         a  
 (*  
 and eval_apply f arg = match f with  
   | Abstraction (_,clos) -> clos arg  
   | _ -> assert false  
 *)  
   
 and eval_branches env brs arg =  
   let (disp, rhs) = Typed.dispatcher brs in  
   let (code, bindings) = run_dispatcher disp arg in  
   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 bind in  
         eval env e  
     | Patterns.Compile.Fail -> Value.Absent  
   
 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.fold_left  
     (fun env (x,i) ->  
        let v = if (i == -1) then v else bindings.(i) in  
        enter_value x v env  
     )  
     env  
     bind  
   
 and eval_rec_funs env l =  
   let slots =  
     List.fold_left  
       (fun accu -> function  
          | { Typed.exp_descr=Typed.Abstraction  
                                { Typed.fun_name = Some f } } as e ->  
              (f, e, ref Absent) :: accu  
          | _ -> assert false  
       ) [] l in  
   let env' =  
     List.fold_left  
       (fun env (f, _ ,s) -> Env.add f (Delayed s) env)  
       env slots in  
   List.iter (fun (_, e, s) -> s := eval env' e) slots;  
   env'  
   
 and eval_map env brs v =  
   map (eval_map_aux env brs) v  
   
 and eval_map_aux env brs acc = function  
   | Pair (x,y) ->  
       let x = eval_branches env brs x in  
       let acc' = Pair (x, Absent) in  
       set_cdr acc acc';  
       eval_map_aux env brs acc' y  
   | String_latin1 (_,_,_,_) | String_utf8 (_,_,_,_) as v ->  
       eval_map_aux env brs acc (normalize v)  
   | Concat (x,y) ->  
       let acc = eval_map_aux env brs acc x in  
       eval_map_aux env brs acc y  
   | _ -> acc  
   
 and eval_transform env brs v =  
   map (eval_transform_aux env brs) v  
   
 and eval_transform_aux env brs acc = function  
   | Pair (x,y) ->  
       (match eval_branches env brs x with  
          | Value.Absent -> eval_transform_aux env brs acc y  
          | x -> eval_transform_aux env brs (append_cdr acc x) y)  
   | String_latin1 (_,_,_,q) | String_utf8 (_,_,_,q) as v ->  
       (* TODO: raise this test outside the loop *)  
       if Types.Char.is_empty (brs.Typed.br_accept)  
       then eval_transform_aux env brs acc q  
       else eval_transform_aux env brs acc (normalize v)  
   | Concat (x,y) ->  
       let acc = eval_transform_aux env brs acc x in  
       eval_transform_aux env brs acc y  
   | _ -> acc  
   
   
 and eval_xtrans env brs v =  
   map (eval_xtrans_aux env brs) v  
   
 and eval_xtrans_aux env brs acc = function  
   | String_utf8 (s,i,j,q) as v ->  
       if Types.Char.is_empty (brs.Typed.br_accept)  
       then  
         let acc' = String_utf8 (s,i,j, Absent) in  
         set_cdr acc acc';  
         eval_xtrans_aux env brs acc' q  
       else eval_xtrans_aux env brs acc (normalize v)  
   | String_latin1 (s,i,j,q) as v ->  
       if Types.Char.is_empty (brs.Typed.br_accept)  
       then  
         let acc' = String_latin1 (s,i,j, Absent) in  
         set_cdr acc acc';  
         eval_xtrans_aux env brs acc' q  
       else eval_xtrans_aux env brs acc (normalize v)  
   | Concat (x,y) ->  
       let acc = eval_xtrans_aux env brs acc x in  
       eval_xtrans_aux env brs acc y  
   | Pair (x,y) ->  
       let acc =  
         match eval_branches env brs x with  
           | Absent ->  
               let x = match x with  
                 | Xml (tag, attr, child) ->  
                     let child = eval_xtrans env brs child in  
                     Xml (tag, attr, child)  
                 | x -> x in  
               let acc' = Pair (x, Absent) in  
               set_cdr acc acc';  
               acc'  
           | x -> append_cdr acc x  
       in  
       eval_xtrans_aux env brs acc y  
   | _ -> acc  
   
 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  
   
   
   
 (* Non tail-rec version:  
   
 and eval_transform env brs = function  
   | Pair (x,y) ->  
       (match eval_branches env brs x with  
          | Value.Absent -> eval_transform env brs y  
          | x -> concat x (eval_transform env brs y))  
   | 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)  
   | q -> q  
   
 and eval_xtrans env brs = function  
   | 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)  
   | Pair (x,y) ->  
       (match eval_branches env brs x with  
          | Absent ->  
              let x = match x with  
                | Xml (tag, attr, child) ->  
                    let child = eval_xtrans env brs child in  
                    Xml (tag, attr, child)  
                | x -> x in  
              let y = eval_xtrans env brs y in  
              Pair (x,y)  
          | x ->  
              let y = eval_xtrans env brs y in  
              concat x y)  
   | q -> q  
   
 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  
   
   
 *)  
   
 (* Evaluator for "compiled" expressions *)  
   
   
 module L = struct  
   
 open Lambda  
   
15  let dispatcher brs =  let dispatcher brs =
16    match brs.brs_compiled with    match brs.brs_compiled with
17      | Some d -> d      | Some d -> d
# Line 305  Line 28 
28          x          x
29    
30    
   
31  let stack = ref (Array.create 1024 Value.Absent)  let stack = ref (Array.create 1024 Value.Absent)
32  let frame = ref 0  let frame = ref 0
33  let sp = ref 0  let sp = ref 0
34    
 let comp_unit () =  
   let r = Array.sub !stack 0 !sp in  
   sp := 0;  
   r  
35    
36  let dump ppf =  let dump ppf =
37    Format.fprintf ppf "sp = %i   frame = %i@." !sp !frame;    Format.fprintf ppf "sp = %i   frame = %i@." !sp !frame;
# Line 338  Line 56 
56    set stack !sp x;    set stack !sp x;
57    incr sp    incr sp
58    
 let calls = ref 0  
   
59  let from_comp_unit = ref (fun cu pos -> assert false)  let from_comp_unit = ref (fun cu pos -> assert false)
60    
61  let eval_var env = function  let eval_var env = function
# Line 395  Line 111 
111    a    a
112    
113  and eval_apply f arg =  and eval_apply f arg =
 (*  Format.fprintf Format.std_formatter  
     "Apply %i@." !calls;  
   incr calls;*)  
114    match f with    match f with
115      | Value.Abstraction2 (local_env,_,body) ->      | Value.Abstraction2 (local_env,_,body) ->
116          let saved_frame = !frame and saved_sp = !sp in          let saved_frame = !frame and saved_sp = !sp in
# Line 410  Line 123 
123      | _  -> assert false      | _  -> assert false
124    
125  and eval_apply_tail_rec f arg =  and eval_apply_tail_rec f arg =
 (*  Format.fprintf Format.std_formatter  
     "Apply tail %i@." !calls;  
   incr calls;*)  
126    match f with    match f with
127      | Value.Abstraction2 (local_env,_,body) ->      | Value.Abstraction2 (local_env,_,body) ->
128          sp := !frame;          sp := !frame;
# Line 555  Line 265 
265        Value.print Format.std_formatter v;        Value.print Format.std_formatter v;
266        failwith ("Cannot find field " ^ (Label.to_string (LabelPool.value l)))        failwith ("Cannot find field " ^ (Label.to_string (LabelPool.value l)))
267    
   
268  and eval_remove_field l = function  and eval_remove_field l = function
269    | Value.Record r -> Value.Record (LabelMap.remove l r)    | Value.Record r -> Value.Record (LabelMap.remove l r)
270    | _ -> assert false    | _ -> assert false
# Line 598  Line 307 
307    | Let_decl (p,e) -> eval_let_decl p e    | Let_decl (p,e) -> eval_let_decl p e
308    | Let_funs funs -> eval_rec_funs funs    | Let_funs funs -> eval_rec_funs funs
309    
 end  
310    
311  let () = eval_apply := L.eval_apply  let comp_unit init code =
312      List.iter push init;
313      List.iter eval code;
314      let r = Array.sub !stack 0 !sp in sp := 0; r
Legend:
Removed from v.923  
changed lines
  Added in v.924
CVS Admin">CVS Admin
 ViewVC Help
Powered by ViewVC 1.1.5