[r2003-03-07 17:31:04 by cvscast] Empty log message

Original author: cvscast
Date: 2003-03-07 17:31:05+00:00

Makefile

@@ -45,7 +45,7 @@ DEBUG = -g
 PACKAGES = pxp-engine,pxp-lex-iso88591,wlexing,camlp4,num,cgi
 OCAMLCP = ocamlc
 OCAMLC = ocamlfind $(OCAMLCP) -package $(PACKAGES)
-OCAMLOPT = ocamlfind ocamlopt  -package $(PACKAGES)
+OCAMLOPT = ocamlfind ocamlopt -package $(PACKAGES)
 
 DEPEND = $(DIRS:=/*.ml) $(DIRS:=/*.mli)
 INCLUDES = $(DIRS:%=-I %)

misc/pool.ml

@@ -49,7 +49,8 @@ struct
 
   let value n = match !values.(n) with Some x -> x | None -> assert false
 
-  let compare (n1 : int) (n2 : int) = Pervasives.compare n1 n2
+  let compare (n1 : int) (n2 : int) = 
+    if n1 < n2 then -1 else if n1 = n2 then 0 else 1
   let hash n = n
   let equal (n1 : int) (n2 : int) = n1 = n2
 end

misc/pool.mli

@@ -23,5 +23,5 @@ sig
   val equal: t -> t -> bool
 end
 
-module Make(H : Hashtbl.HashedType) : T with type value = H.t
+module Make(H : Hashtbl.HashedType) : T with type value = H.t and type t = int
 

parser/parser.ml

@@ -51,7 +51,7 @@ let parse_char loc s =
 
 let char_list pos s = 
   let s = seq_of_string pos s in
-  List.map (fun (loc,c) -> mk loc (Cst (Types.Char (Chars.Unichar.from_char c)))) s
+  List.map (fun (loc,c) -> mk loc (Cst (Types.Char (Chars.mk_char c)))) s
 
 
 EXTEND
@@ -153,7 +153,7 @@ EXTEND
 	       | `Explode x -> mk x.loc (Op ("@",[x;q]))
 	  ) l e
     | t = [ a = TAG -> 
-	      mk loc (Cst (Types.Atom (Types.AtomPool.mk a)))
+	      mk loc (Cst (Types.Atom (Atoms.mk a)))
 	  | "<"; e = expr LEVEL "no_appl" -> e ];
 	a = expr_attrib_spec; ">"; c = expr ->
 	mk loc (Xml (t, mk loc (Pair (a,c))))
@@ -238,14 +238,14 @@ EXTEND
     | "("; a = LIDENT; ":="; c = const; ")" -> Elem (mk loc (Constant (a,c)))
     | UIDENT "PCDATA" -> string_regexp
     | i = STRING1; "--"; j = STRING1 ->
-	let i = Chars.Unichar.from_char (parse_char loc i)
-	and j = Chars.Unichar.from_char (parse_char loc j) in
+	let i = Chars.mk_char (parse_char loc i)
+	and j = Chars.mk_char (parse_char loc j) in
         Elem (mk loc (Internal (Types.char (Chars.char_class i j))))
     |  s = STRING1 ->
 	let s = seq_of_string loc s in
 	List.fold_right
 	  (fun (loc,c) accu -> 
-	     let c = Chars.Unichar.from_char c in
+	     let c = Chars.mk_char c in
 	     let c = Chars.atom c in
 	     Seq (Elem (mk loc (Internal (Types.char c))), accu))
 	  s
@@ -270,17 +270,17 @@ EXTEND
       | "("; a = LIDENT; ":="; c = const; ")" -> mk loc (Constant (a,c))
       | a = UIDENT -> mk loc (PatVar a)
       | i = INT ; "--"; j = INT -> 
-          let i = Big_int.big_int_of_string i 
-	  and j = Big_int.big_int_of_string j in
+          let i =  Intervals.mk i 
+	  and j =  Intervals.mk j in
           mk loc (Internal (Types.interval (Intervals.bounded i j)))
       | i = INT -> 
-          let i = Big_int.big_int_of_string i  in
+          let i =  Intervals.mk i  in
           mk loc (Internal (Types.interval (Intervals.atom i)))
       | "*"; "--"; j = INT ->
-	  let j = Big_int.big_int_of_string j in
+	  let j =  Intervals.mk j in
           mk loc (Internal (Types.interval (Intervals.left j)))
       | i = INT; "--"; "*" ->
-	  let i = Big_int.big_int_of_string i in
+	  let i = Intervals.mk i in
           mk loc (Internal (Types.interval (Intervals.right i)))
       | i = char ->
           mk loc (Internal (Types.char (Chars.char_class i i)))
@@ -296,7 +296,7 @@ EXTEND
 	  [ "<"; LIDENT "_" -> mk loc (Internal (Types.atom (Atoms.any)))
 	  | a = TAG -> 
 	      mk loc 
-	      (Internal (Types.atom (Atoms.atom (Types.AtomPool.mk a)))) ]
+	      (Internal (Types.atom (Atoms.atom (Atoms.mk a)))) ]
 	| [ "<"; t = pat -> t ]
 	];
 	a = attrib_spec; ">"; c = pat ->
@@ -308,7 +308,7 @@ EXTEND
 		       mk loc (Internal
 				 (Types.char
 				    (Chars.atom
-				       (Chars.Unichar.from_char c))))) s in
+				       (Chars.mk_char c))))) s in
 	  let s = s @ [mk loc (Internal (Sequence.nil_type))] in
 	  multi_prod loc s
       ]
@@ -326,15 +326,15 @@ EXTEND
   
   char:
     [ 
-      [ c = STRING1 -> Chars.Unichar.from_char (parse_char loc c)
-      | "!"; i = INT -> Chars.Unichar.from_int (int_of_string i) ]
+      [ c = STRING1 -> Chars.mk_char (parse_char loc c)
+      | "!"; i = INT -> Chars.mk_int (int_of_string i) ]
     ];
      
 
   const:
     [ 
-      [ i = INT -> Types.Integer (Big_int.big_int_of_string i)
-      | "`"; a = [LIDENT | UIDENT] -> Types.Atom (Types.AtomPool.mk a)
+      [ i = INT -> Types.Integer (Intervals.mk i)
+      | "`"; a = [LIDENT | UIDENT] -> Types.Atom (Atoms.mk a)
       | c = char -> Types.Char c ]
     ];
 

runtime/eval.ml

@@ -9,7 +9,7 @@ let enter_global x v = global_env := Env.add x v !global_env
 
 
 let exn_int_of = CDuceExn (Pair (
-			     Atom (Types.AtomPool.mk "Invalid_argument"),
+			     Atom (Atoms.mk "Invalid_argument"),
 			     string "int_of"))
 
 
@@ -115,23 +115,23 @@ and eval_dot l = function
   | _ -> assert false
 
 and eval_add x y = match (x,y) with
-  | (Integer x, Integer y) -> Integer (Big_int.add_big_int x y)
+  | (Integer x, Integer y) -> Integer (Intervals.vadd x y)
   | _ -> assert false
 
 and eval_mul x y = match (x,y) with
-  | (Integer x, Integer y) -> Integer (Big_int.mult_big_int x y)
+  | (Integer x, Integer y) -> Integer (Intervals.vmult x y)
   | _ -> assert false
 
 and eval_sub x y = match (x,y) with
-  | (Integer x, Integer y) -> Integer (Big_int.sub_big_int x y)
+  | (Integer x, Integer y) -> Integer (Intervals.vsub x y)
   | _ -> assert false
 
 and eval_div x y = match (x,y) with
-  | (Integer x, Integer y) -> Integer (Big_int.div_big_int x y)
+  | (Integer x, Integer y) -> Integer (Intervals.vdiv x y)
   | _ -> assert false
 
 and eval_mod x y = match (x,y) with
-  | (Integer x, Integer y) -> Integer (Big_int.mod_big_int x y)
+  | (Integer x, Integer y) -> Integer (Intervals.vmod x y)
   | _ -> assert false
 
 and eval_load_xml e =
@@ -142,7 +142,7 @@ and eval_load_html e =
 
 and eval_int_of e =
   let s = get_string e in
-  try Integer (Big_int.big_int_of_string s)
+  try Integer (Intervals.mk s)
   with Failure _ -> raise exn_int_of
   
 and eval_print_xml v =

runtime/load_xml.ml

@@ -24,7 +24,7 @@ let attrib att =
   SortedMap.from_list (fun _ _ -> assert false) att
 
 let elem tag att child =
-  Xml (Atom (Types.AtomPool.mk tag), Pair (Record (attrib att), child))
+  Xml (Atom (Atoms.mk tag), Pair (Record (attrib att), child))
 
 let load_xml_aux s =
   let config = { default_config with 

runtime/print_xml.ml

@@ -5,7 +5,7 @@ open Pxp_types
 open Value
 
 let exn_print_xml = CDuceExn (Pair (
-				Atom (Types.AtomPool.mk "Invalid_argument"),
+				Atom (Atoms.mk "Invalid_argument"),
 				string "print_xml"))
 
 
@@ -42,7 +42,7 @@ let string_of_xml v=
 
   let rec print_elt = function
     | Xml (Atom tag, Pair (Record attrs, content)) ->
-	let tag = Types.AtomPool.value tag in
+	let tag = Atoms.value tag in
 	let attrs = List.map (fun (n,v) -> 
 		       if not (is_str v) then raise exn_print_xml;
 		       (Types.LabelPool.value n,get_string v)) attrs in
@@ -53,7 +53,7 @@ let string_of_xml v=
 	      print_content content;
 	      element_end tag)
     | Char x ->
- 	wds (String.make 1 (Chars.Unichar.to_char x)); (* TODO: opt *)
+ 	wds (String.make 1 (Chars.to_char x)); (* TODO: opt *)
    | _ -> raise exn_print_xml
   and print_content = function
     | String (i,j,s,q) ->

runtime/value.ml

@@ -2,9 +2,9 @@ type t =
   | Pair of t * t
   | Xml of t * t
   | Record of (Types.label,t) SortedMap.t
-  | Atom of Types.atom
-  | Integer of Big_int.big_int
-  | Char of Chars.Unichar.t
+  | Atom of Atoms.v
+  | Integer of Intervals.v
+  | Char of Chars.v
   | Abstraction of (Types.descr * Types.descr) list * (t -> t)
   | String of int * int * string * t
 
@@ -25,7 +25,7 @@ let get_string e =
     | String (i,j,_,y) -> compute_len (accu + j - i) y
     | _ -> accu in
   let rec fill pos s = function
-    | Pair (Char x,y) -> s.[pos] <- Chars.Unichar.to_char x; fill (pos + 1) s y
+    | Pair (Char x,y) -> s.[pos] <- Chars.to_char x; fill (pos + 1) s y
     | String (i,j,src,y) -> 
 	String.blit src i s pos (j - i); fill (pos + j - i) s y
     | _ -> s in
@@ -54,15 +54,15 @@ let rec print ppf v =
     | Pair (x,y) -> Format.fprintf ppf "(%a,%a)" print x print y
     | Xml (x,y)  -> print_xml ppf (x,y)
     | Record l -> Format.fprintf ppf "{%a }" print_record l
-    | Atom a ->	Format.fprintf ppf "`%s" (Types.AtomPool.value a)
-    | Integer i -> Format.fprintf ppf "%s" (Big_int.string_of_big_int i)
-    | Char c ->	Chars.Unichar.print ppf c
+    | Atom a ->	Atoms.print_v ppf a
+    | Integer i -> Intervals.print_v ppf i
+    | Char c ->	Chars.print_v ppf c
     | Abstraction _ -> Format.fprintf ppf "<fun>"
     | String (i,j,s,q) -> 
 	Format.fprintf ppf "<string:%i-%i,%S,%a>" i j s print q
 and print_quoted_str ppf = function
   | Pair (Char c, q) -> 
-      Chars.Unichar.print_in_string ppf c; 
+      Chars.print_v_in_string ppf c; 
       print_quoted_str ppf q
   | String (i,j,s, q) ->
       Format.fprintf ppf "%s" (String.escaped (String.sub s i (j-i)));
@@ -80,7 +80,7 @@ and print_seq ppf = function
   | _ -> ()
 and print_str ppf = function
   | Pair (Char c,y) ->
-      let c = Chars.Unichar.to_char c in
+      let c = Chars.to_char c in
       Format.fprintf ppf "%s" (Char.escaped c);
       print_str ppf y
   | v ->
@@ -90,7 +90,7 @@ and print_str ppf = function
 and print_xml ppf = function
   | (Atom tag, Pair (Record attr,content)) ->
       Format.fprintf ppf "@[<hv2><%s%a>[@ %a@]]" 
-      (Types.AtomPool.value tag)
+      (Atoms.value tag)
       print_record attr
       print_seq content
   | _ -> assert false
@@ -107,6 +107,5 @@ and print_field ppf (l,v) =
 let normalize = function
   | String (i,j,s,q) ->
       if i = j then q else
-	Pair (Char (Chars.Unichar.from_char s.[i]),
-	      String (succ i,j,s,q))
+	Pair (Char (Chars.mk_char s.[i]), String (succ i,j,s,q))
   | v -> assert false

runtime/value.mli

@@ -3,9 +3,9 @@ type t =
   | Pair of t * t
   | Xml of t * t
   | Record of (Types.label,t) SortedMap.t
-  | Atom of Types.atom
-  | Integer of Big_int.big_int
-  | Char of Chars.Unichar.t
+  | Atom of Atoms.v
+  | Integer of Intervals.v
+  | Char of Chars.v
   | Abstraction of (Types.descr * Types.descr) list * (t -> t)
 
 (* Derived forms *)

tests/integers.cd

@@ -2,9 +2,10 @@ let fun facto (Int -> Int)
  | 0 | 1 -> 1
  | n -> n * (facto (n - 1))
 in
-facto 300;;
+facto 10000;;
 
 
+(*
 type Pos = 0--*;;
 
 let fun abs (Int -> Pos)
@@ -34,3 +35,4 @@ let fun eval ( Expr -> Int )
   | n -> n 
 in
 eval (`add, 10, (`add, 20, 5));;
+*)

tests/stress_opt_arg.cd

@@ -16,10 +16,10 @@ debug compile T
    ({ c = c } | ( c := `B)) &
    ({ d = d } | ( d := `B)) &
    ({ e = e } | ( e := `B)) &
-   ({ f = f } | ( f := `B)) &
+(*   ({ f = f } | ( f := `B)) &
    ({ g = g } | ( g := `B)) &
    ({ h = h } | ( h := `B)) &
-   ({ i = i } | ( i := `B)) &
+   ({ i = i } | ( i := `B)) & *)
 (*   ({ j = j } | ( j := `B)) &
    ({ k = k } | ( k := `B)) &
    ({ l = l } | ( l := `B)) &

types/atoms.ml

-type 'a t = Finite of 'a list | Cofinite of 'a list
+module HashedString = 
+struct 
+  type t = string 
+  let hash = Hashtbl.hash
+  let equal = (=)
+end
+
+module AtomPool  = Pool.Make(HashedString)
+type v = AtomPool.t
+let value = AtomPool.value
+let mk = AtomPool.mk
+
+type t = Finite of v list | Cofinite of v list
 
 let empty = Finite []
 let any   = Cofinite []
@@ -38,23 +50,46 @@ let is_atom = function
   | Finite [a] -> Some a
   | _ -> None
       
-let sample except = function
+let sample = function
   | Finite (x :: _) -> x
-  | Cofinite l -> except l
+  | Cofinite l -> AtomPool.dummy_min
   | Finite [] -> raise Not_found
 
+let print_v ppf a = 
+  if a = AtomPool.dummy_min then
+    Format.fprintf ppf "(almost any atom)"
+  else
+    Format.fprintf ppf "`%s" (value a)
 
-let print any f = function
-  | Finite l -> List.map (fun x ppf -> f ppf x) l
+let print = function
+  | Finite l -> List.map (fun x ppf -> print_v ppf x) l
   | Cofinite [] ->
-      [ fun ppf -> Format.fprintf ppf "%s" any ]
+      [ fun ppf -> Format.fprintf ppf "Atom" ]
   | Cofinite [h] ->
-      [ fun ppf -> Format.fprintf ppf "@[%s - %a@]" any f h ]
+      [ fun ppf -> Format.fprintf ppf "@[Atom - %a@]" print_v h ]
   | Cofinite (h::t) -> 
       [ fun ppf -> 
-	  Format.fprintf ppf "@[%s - (" any;
-	  f ppf h;
-	  List.iter (fun x -> Format.fprintf ppf " |@ %a" f x) t;
+	  Format.fprintf ppf "@[Atom - (";
+	  print_v ppf h;
+	  List.iter (fun x -> Format.fprintf ppf " |@ %a" print_v x) t;
 	  Format.fprintf ppf ")@]" ]
 
+let rec hash_seq accu = function
+  | t::rem -> hash_seq (accu * 17 + t) rem
+  | [] -> accu
+
+let hash accu = function
+  | Finite l -> hash_seq (accu + 1) l
+  | Cofinite l -> hash_seq (accu + 3) l
 
+let rec equal_rec l1 l2 =
+  (l1 == l2) ||
+  match (l1,l2) with
+    | (x1::l1,x2::l2) -> (x1 == x2) && (equal_rec l1 l2)
+    | _ -> false
+
+let equal t1 t2 = match (t1,t2) with
+  | (Finite l1, Finite l2) -> equal_rec l1 l2
+  | (Cofinite l1, Cofinite l2) -> equal_rec l1 l2
+  | _ -> false
+  

types/atoms.mli

-type 'a t (* = Finite of 'a list | Cofinite of 'a list *)
+type v
+val value: v -> string
+val mk: string -> v
+val print_v: Format.formatter -> v -> unit
 
-val empty : 'a t
-val any   : 'a t
 
-val cup : 'a t -> 'a t -> 'a t
-val cap : 'a t -> 'a t -> 'a t
-val diff : 'a t -> 'a t -> 'a t
-val atom : 'a -> 'a t
+type t
+val hash: int -> t -> int
+val equal: t -> t -> bool
+val print : t -> (Format.formatter -> unit) list
+
+val empty : t
+val any   : t
+
+val cup : t -> t -> t
+val cap : t -> t -> t
+val diff : t -> t -> t
+val atom : v -> t
+
+val contains : v -> t -> bool
+val is_empty : t -> bool
+val is_atom : t -> v option
+val sample : t -> v
 
-val contains : 'a -> 'a t -> bool
-val is_empty : 'a t -> bool
-val is_atom : 'a t -> 'a option
-val sample : ('a list -> 'a) -> 'a t -> 'a
 
-val print : string -> (Format.formatter -> 'a -> unit) -> 'a t -> 
-  (Format.formatter -> unit) list

types/boolean.ml

@@ -20,16 +20,18 @@ let cup t s =
       List.filter (fun (p,n) -> not (List.exists (may_remove (p,n)) s)) t in 
     SortedList.cup s t
 
-let clean t =
+let tot = ref 0
+let clean accu t =
   let rec aux accu = function
     | (p,n) :: rem ->
 	if (List.exists (may_remove (p,n)) accu)
 	  || (List.exists (may_remove (p,n)) rem)
 	then aux accu rem
-	else aux((p,n) :: accu) rem 
-    | [] -> accu 
+	else aux ((p,n)::accu) rem 
+    | [] -> accu
   in
-  List.rev (aux [] t)
+  SortedList.from_list (aux accu t)
+
 
     
 
@@ -49,17 +51,12 @@ let cap s t =
   else if (s == empty) || (t == empty) then empty
   else
     let (lines1,common,lines2) = SortedList.split s t in
-    let lines =
-      fold2 
-        (fun lines (p1,n1) (p2,n2) ->
-           if (SortedList.disjoint p1 n2) && (SortedList.disjoint p2 n1) 
-           then (SortedList.cup p1 p2, SortedList.cup n1 n2) :: lines
-           else lines)
-        []
-        lines1
-	lines2
+    let rec aux lines (p1,n1) (p2,n2) =
+        if (SortedList.disjoint p1 n2) && (SortedList.disjoint p2 n1) 
+        then (SortedList.cup p1 p2, SortedList.cup n1 n2) :: lines
+	else lines
     in
-    clean (SortedList.cup common (SortedList.from_list lines))
+    clean common (fold2 aux [] lines1 lines2)
 
 let diff c1 c2 =
   if c2 == full then empty

types/builtin.ml

 let intstr =
   Sequence.plus (Types.char (Chars.char_class
-			       (Chars.Unichar.from_char '0')
-			       (Chars.Unichar.from_char '9')
+			       (Chars.mk_char '0')
+			       (Chars.mk_char '9')
 			    )
 		)
 

types/chars.ml

-module Unichar = struct
-  type t = int
+type v = int
 
-  let max = 0x10FFFF
+let max_char = 0x10FFFF
 
-  let from_int c = 
-    if (c < 0) || (c > max) then 
-      failwith "Chars.from_int: code point out of bound";
-    c
-
-  let from_char c =
-    Char.code c
+let mk_int c = 
+  if (c < 0) || (c > max_char) then 
+    failwith "Chars.mk_int: code point out of bound";
+  c
 
-  let to_int c = c
+let mk_char c =
+  Char.code c
+    
+let to_int c = c
 
-  let to_char c =
-    if (c > 255) then failwith "to_char: code-point > 255";
-    Char.chr c
+let to_char c =
+  if (c > 255) then failwith "Chars.to_char: code-point > 255";
+  Char.chr c
 
-  let print ppf c =
-    if (c < 128) 
-    then Format.fprintf ppf "%C" (Char.chr c)
-    else Format.fprintf ppf "#x%x" c
+let print_v ppf c =
+  if (c < 128) 
+  then Format.fprintf ppf "%C" (Char.chr c)
+  else Format.fprintf ppf "#x%x" c
 
-  let print_in_string ppf c =
-    Format.fprintf ppf "%c" (Char.chr c)
-end
+let print_v_in_string ppf c =
+  Format.fprintf ppf "%c" (Char.chr c)
+      
+type t = (v * v) list
 
-type t = (Unichar.t * Unichar.t) list
+let rec hash accu = function
+  | (i,j)::rem -> hash (accu * 257 + i * 17 + j) rem
+  | [] -> accu + 3
 
-let max_char = Unichar.max
+let rec equal l1 l2 = 
+  (l1 == l2) ||
+  match (l1,l2) with
+    | (i1,j1)::l1, (i2,j2)::l2 -> (i1==i2) && (j1==j2) && (equal l1 l2)
+    | _ -> false
 
 let from_int c = 
   if (c < 0) || (c > max_char) then 
@@ -84,8 +90,8 @@ let print =
     (fun (a,b) ->
        if a = b 
        then fun ppf -> 
-	 Unichar.print ppf a
+	 print_v ppf a
        else fun ppf -> 
 	 if a = 0 && b = max_char then Format.fprintf ppf "Char" else
-	 Format.fprintf ppf "%a--%a" Unichar.print a Unichar.print b
+	 Format.fprintf ppf "%a--%a" print_v a print_v b
     )

types/chars.mli

-module Unichar : sig
-  type t
-  val from_int: int -> t
-  val from_char: char -> t
-  val to_int: t -> int
-  val to_char: t -> char
+type v
+val mk_int: int -> v
+val mk_char: char -> v
+val to_int: v -> int
+val to_char: v -> char
+val print_v : Format.formatter -> v -> unit
+val print_v_in_string : Format.formatter -> v -> unit
 
-  val print : Format.formatter -> t -> unit
-  val print_in_string : Format.formatter -> t -> unit
-end
-
-type t = (Unichar.t * Unichar.t) list
+type t (* = (Unichar.t * Unichar.t) list *)
+val equal : t -> t -> bool
+val hash  : int -> t -> int
+val print : t -> (Format.formatter -> unit) list
 
 val empty : t
 val any   : t
 val cup   : t -> t -> t
 val cap   : t -> t -> t
 val diff  : t -> t -> t
-val char_class  : Unichar.t -> Unichar.t -> t
-val atom  : Unichar.t -> t
+val char_class  : v -> v -> t
+val atom  : v -> t