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

Diff of /runtime/eval.ml

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

revision 517 by abate, Tue Jul 10 17:40:08 2007 UTC revision 518 by abate, Tue Jul 10 17:40:57 2007 UTC
# Line 5  Line 5 
5  exception MultipleDeclaration of id  exception MultipleDeclaration of id
6  type env = t Env.t  type env = t Env.t
7    
 let set_cdr x q = Obj.set_field (Obj.repr x) 1 (Obj.repr q)  
   
 let seq_accu () = Pair (nil,nil)  
 let append_accu x y = let acc = Pair (y,nil) in set_cdr x acc; acc  
 let get_accu = function  
   | Pair (x,y) -> y  
   | _ -> assert false  
   
   
8  (* Evaluation of expressions *)  (* Evaluation of expressions *)
9    
10    let make_accu () = Pair(nil,Absent)
11    let get_accu a = snd (Obj.magic a)
12    
13    let dummy () = Absent
14    
15  let rec eval env e0 = match e0.Typed.exp_descr with  let rec eval env e0 = match e0.Typed.exp_descr with
16    | Typed.Forget (e,_) -> eval env e    | Typed.Forget (e,_) -> eval env e
# Line 114  Line 109 
109        env slots in        env slots in
110    List.map (fun (f, e, s) -> s := eval env' e; (f, !s)) slots    List.map (fun (f, e, s) -> s := eval env' e; (f, !s)) slots
111    
112    (*
113  and eval_map env brs = function  and eval_map env brs = function
114    | Pair (x,y) ->    | Pair (x,y) ->
115        let x = eval_branches env brs x in        let x = eval_branches env brs x in
# Line 121  Line 117 
117    | String_latin1 (_,_,_,_) | String_utf8 (_,_,_,_) as v ->    | String_latin1 (_,_,_,_) | String_utf8 (_,_,_,_) as v ->
118        eval_map env brs (normalize v)        eval_map env brs (normalize v)
119    | q -> q    | q -> q
120    *)
121    
122    and eval_map env brs v =
123      let acc0 = make_accu () in
124      let acc = eval_map_aux env brs acc0 v in
125      set_cdr acc nil;
126      get_accu acc0
127    
128    
129    and eval_map_aux env brs acc = function
130      | Pair (x,y) ->
131          let x = eval_branches env brs x in
132          let acc' = Pair (x, Absent) in
133          set_cdr acc acc';
134          eval_map_aux env brs acc' y
135      | String_latin1 (_,_,_,_) | String_utf8 (_,_,_,_) as v ->
136          eval_map_aux env brs acc (normalize v)
137      | q -> acc
138    
139    
140    (*
141  and eval_transform env brs = function  and eval_transform env brs = function
142    | Pair (x,y) ->    | Pair (x,y) ->
143        (match eval_branches env brs x with        (match eval_branches env brs x with
# Line 133  Line 148 
148        then eval_transform env brs q        then eval_transform env brs q
149        else eval_transform env brs (normalize v)        else eval_transform env brs (normalize v)
150    | q -> q    | q -> q
151  (*  *)
152    
153  and eval_transform env brs v =  and eval_transform env brs v =
154    let acc = seq_accu () in    let acc0 = make_accu () in
155    eval_transform_aux env brs acc v;    let acc = eval_transform_aux env brs acc0 v in
156    get_accu acc    set_cdr acc nil;
157      get_accu acc0
158    
159  and eval_transform_aux env brs acc = function  and eval_transform_aux env brs acc = function
160    | Pair (x,y) ->    | Pair (x,y) ->
161        let x =        let acc =
162          match eval_branches env brs x with          match eval_branches env brs x with
163            | Value.Absent -> Value.nil            | Value.Absent -> acc
164            | x -> List.fold_left add_accu acc x            | x -> append_cdr acc x
165  x in                (* Need to copy in general; optimization: detect fresh
166        concat x (eval_transform env brs y)                  constructors ... *)
167          in
168          eval_transform_aux env brs acc y
169    | String_latin1 (_,_,_,q) | String_utf8 (_,_,_,q) as v ->    | String_latin1 (_,_,_,q) | String_utf8 (_,_,_,q) as v ->
170        if Types.Char.is_empty (brs.Typed.br_accept)        if Types.Char.is_empty (brs.Typed.br_accept)
171        then eval_transform env brs q        then eval_transform_aux env brs acc q
172        else eval_transform env brs (normalize v)        else eval_transform_aux env brs acc (normalize v)
173    | q -> q    | q -> acc
 *)  
174    
175  and eval_xtrans env brs = function  and eval_xtrans env brs = function
176    | String_utf8 (s,i,j,q) as v ->    | String_utf8 (s,i,j,q) as v ->
Legend:
Removed from v.517  
changed lines
  Added in v.518
CVS Admin">CVS Admin
 ViewVC Help
Powered by ViewVC 1.1.5