[r2003-06-17 05:33:21 by cvscast] Clean -- Alain

Original author: cvscast
Date: 2003-06-17 05:33:21+00:00

runtime/eval.ml

@@ -5,17 +5,13 @@ open Ident
 exception MultipleDeclaration of id
 type env = t Env.t
 
-(* Evaluation of expressions *)
+(* To write tail-recursive map-like iteration *)
 
 let make_accu () = Pair(nil,Absent)
 let get_accu a = snd (Obj.magic a)
-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
 
-let dummy () = Absent
+(* Evaluation of expressions *)
 
 let rec eval env e0 = match e0.Typed.exp_descr with
   | Typed.Forget (e,_) -> eval env e
@@ -75,9 +71,6 @@ and eval_apply f arg = match f with
   | Abstraction (_,clos) -> clos arg
   | _ -> assert false
 
-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
@@ -114,16 +107,6 @@ and eval_rec_funs env l =
       env slots in
   List.map (fun (f, e, s) -> s := eval env' e; (f, !s)) slots
 
-(*
-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_map env brs v =
   map (eval_map_aux env brs) v
 
@@ -137,31 +120,14 @@ and eval_map_aux env brs acc = function
       eval_map_aux env brs acc (normalize v)
   | _ -> acc
 
-
-(*  
-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_transform env brs v =
   map (eval_transform_aux env brs) v
 
 and eval_transform_aux env brs acc = function
   | Pair (x,y) -> 
-      let acc = 
-	match eval_branches env brs x with 
-	  | Value.Absent -> acc
-	  | x -> append_cdr acc x
-	      (* Need to copy in general; optimization: detect fresh
-		constructors ... *)
+      let acc = match eval_branches env brs x with 
+	| Value.Absent -> acc
+	| x -> append_cdr acc x
       in
       eval_transform_aux env brs acc y
   | String_latin1 (_,_,_,q) | String_utf8 (_,_,_,q) as v -> 
@@ -170,32 +136,6 @@ and eval_transform_aux env brs acc = function
       else eval_transform_aux env brs acc (normalize v)
   | _ -> acc
 
-(*
-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_xtrans env brs v =
   map (eval_xtrans_aux env brs) v
@@ -232,8 +172,6 @@ and eval_xtrans_aux env brs acc = function
       eval_xtrans_aux env brs acc y
   | _ -> acc
 
-
-
 and eval_dot l = function
   | Record r -> LabelMap.assoc l r
   | _ -> assert false
@@ -241,3 +179,53 @@ and eval_dot l = function
 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
+
+
+*)