[r2003-06-17 05:10:58 by cvscast] map-transform => tail-rec -- Alain

Original author: cvscast
Date: 2003-06-17 05:10:58+00:00

Makefile.distrib

 include Makefile.conf
 VERSION = 0.0.91
 
-PACKAGES = -package "pxp-engine pxp-lex-iso88591 wlexing camlp4 num cgi pcre netstring"
+PACKAGES = pxp-engine pxp-lex-iso88591 wlexing camlp4 num cgi pcre netstring
 ifeq ($(PXP_WLEX), true)
-  PACKAGES += -package pxp-wlex-utf8
+  PACKAGES += pxp-wlex-utf8
 else
-  PACKAGES += -package pxp-lex-utf8
+  PACKAGES += pxp-lex-utf8
 endif
 
 SYNTAX = camlp4o -I misc/ pa_extend.cmo \
@@ -20,7 +20,7 @@ else
 endif
 
 ifeq ($(EXPAT), true)
-	PACKAGES += -package expat
+	PACKAGES += expat
 	SYNTAX += -symbol EXPAT=
 endif
 
@@ -38,8 +38,8 @@ else
 endif
 
 OPT = -warn-error A
-CAMLC = ocamlfind $(CAMLC_P) $(OPT) $(PACKAGES)
-CAMLOPT = ocamlfind $(CAMLOPT_P) $(OPT) $(PACKAGES)
+CAMLC = ocamlfind $(CAMLC_P) $(OPT) -package "$(PACKAGES)"
+CAMLOPT = ocamlfind $(CAMLOPT_P) $(OPT) -package "$(PACKAGES)"
 
 ifeq ($(NATIVE), true)
 	EXTENSION = cmx

runtime/eval.ml

@@ -5,17 +5,12 @@ open Ident
 exception MultipleDeclaration of id
 type env = t Env.t
 
-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
-
-
 (* Evaluation of expressions *)
 
+let make_accu () = Pair(nil,Absent)
+let get_accu a = snd (Obj.magic a)
+
+let dummy () = Absent
 
 let rec eval env e0 = match e0.Typed.exp_descr with
   | Typed.Forget (e,_) -> eval env e
@@ -114,6 +109,7 @@ 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
@@ -121,8 +117,27 @@ and eval_map env brs = function
   | String_latin1 (_,_,_,_) | String_utf8 (_,_,_,_) as v -> 
       eval_map env brs (normalize v)
   | q -> q
+*)
+
+and eval_map env brs v =
+  let acc0 = make_accu () in
+  let acc = eval_map_aux env brs acc0 v in
+  set_cdr acc nil;
+  get_accu acc0
   
 
+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)
+  | q -> acc
+
+
+(*  
 and eval_transform env brs = function
   | Pair (x,y) -> 
       (match eval_branches env brs x with 
@@ -133,25 +148,29 @@ and eval_transform env brs = function
       then eval_transform env brs q
       else eval_transform env brs (normalize v)
   | q -> q
-(*
+*)
+
 and eval_transform env brs v =
-  let acc = seq_accu () in
-  eval_transform_aux env brs acc v;
-  get_accu acc
+  let acc0 = make_accu () in
+  let acc = eval_transform_aux env brs acc0 v in
+  set_cdr acc nil;
+  get_accu acc0
+
 and eval_transform_aux env brs acc = function
   | Pair (x,y) -> 
-      let x = 
+      let acc = 
 	match eval_branches env brs x with 
-	  | Value.Absent -> Value.nil 
-	  | x -> List.fold_left add_accu acc x
-x in
-      concat x (eval_transform env brs y)
+	  | Value.Absent -> acc
+	  | x -> append_cdr acc x
+	      (* Need to copy in general; optimization: detect fresh
+		constructors ... *)
+      in
+      eval_transform_aux env brs acc 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
-*)
+      then eval_transform_aux env brs acc q
+      else eval_transform_aux env brs acc (normalize v)
+  | q -> acc
 
 and eval_xtrans env brs = function
   | String_utf8 (s,i,j,q) as v ->

runtime/value.ml

@@ -275,16 +275,6 @@ let rec compare x y =
       | Integer _,_ -> -1 | _, Integer _ -> 1
 
 
-(* (* BUGGY *)
-let explode_rev s =
-  let rec aux acc = function
-    | v when v = nil -> acc
-    | Pair (v, seq) -> aux (v::acc) seq
-    | v -> [v]
-  in
-  aux [] s
-*)
-
 let iter_xml pcdata_callback other_callback =
   let rec aux = function
     | v when compare v nil = 0 -> ()
@@ -305,5 +295,33 @@ let iter_xml pcdata_callback other_callback =
   function
     | Xml (_,_,cont) -> aux cont
     | _ -> raise (Invalid_argument "Value.iter_xml")
-;;
 
+
+type pair = { dummy : t; mutable pair_tl : t }
+type str  = { dummy1 : t; dummy2 : t; dummy3 : t; mutable str_tl : t }
+
+(* Could optimize this function by changing the order of the fields
+   in String_latin1, String_utf8 *)
+
+let set_cdr cell tl =
+  match cell with
+    | Pair (_,_) -> (Obj.magic cell).pair_tl <- tl
+    | String_latin1 (_,_,_,_) 
+    | String_utf8(_,_,_,_)-> (Obj.magic cell).str_tl <- tl
+    | _ -> assert false
+
+let rec append_cdr cell tl =
+  match tl with
+    | Pair (x,tl) -> 
+	let cell' = Pair (x,Absent) in
+	set_cdr cell cell';
+	append_cdr cell' tl
+    | String_latin1 (s,i,j,tl) ->
+	let cell' = String_latin1 (s,i,j,Absent) in
+	set_cdr cell cell';
+	append_cdr cell' tl
+    | String_utf8 (s,i,j,tl) ->
+	let cell' = String_utf8 (s,i,j,Absent) in
+	set_cdr cell cell';
+	append_cdr cell' tl
+    | _ -> cell

runtime/value.mli

@@ -56,3 +56,7 @@ val get_int : t -> int
 val get_fields : t -> (string * t) list
 
 val compare : t -> t -> int
+
+
+val set_cdr : t -> t -> unit
+val append_cdr : t -> t -> t