[r2003-03-22 15:22:10 by cvscast] Empty log message

Original author: cvscast
Date: 2003-03-22 15:22:11+00:00

Makefile

@@ -5,7 +5,7 @@ CLEAN_DIRS = $(DIRS) tools tests
 
 # Objects to build
 
-MISC = misc/state.cmo misc/pool.cmo misc/encodings.cmo
+MISC = misc/state.cmo misc/pool.cmo misc/encodings.cmo misc/bool.cmo
 
 PARSER = parser/lexer.cmo parser/location.cmo \
          parser/wlexer.cmo \

depend

+misc/bool.cmo: misc/bool.cmi 
+misc/bool.cmx: misc/bool.cmi 
 misc/encodings.cmo: misc/encodings.cmi 
 misc/encodings.cmx: misc/encodings.cmi 
 misc/pool.cmo: misc/state.cmi misc/pool.cmi 
@@ -42,10 +44,12 @@ types/intervals.cmo: types/intervals.cmi
 types/intervals.cmx: types/intervals.cmi 
 types/normal.cmo: types/normal.cmi 
 types/normal.cmx: types/normal.cmi 
-types/patterns.cmo: types/ident.cmo types/sortedList.cmi types/sortedMap.cmi \
-    misc/state.cmi types/types.cmi types/patterns.cmi 
-types/patterns.cmx: types/ident.cmx types/sortedList.cmx types/sortedMap.cmx \
-    misc/state.cmx types/types.cmx types/patterns.cmi 
+types/patterns.cmo: types/atoms.cmi types/chars.cmi types/ident.cmo \
+    types/sortedList.cmi types/sortedMap.cmi misc/state.cmi types/types.cmi \
+    types/patterns.cmi 
+types/patterns.cmx: types/atoms.cmx types/chars.cmx types/ident.cmx \
+    types/sortedList.cmx types/sortedMap.cmx misc/state.cmx types/types.cmx \
+    types/patterns.cmi 
 types/recursive_noshare.cmo: types/recursive.cmo misc/state.cmi 
 types/recursive_noshare.cmx: types/recursive.cmx misc/state.cmx 
 types/recursive_share.cmo: types/recursive.cmo misc/state.cmi 
@@ -58,10 +62,10 @@ types/sortedMap.cmo: types/sortedMap.cmi
 types/sortedMap.cmx: types/sortedMap.cmi 
 types/type_bool.cmo: types/boolean.cmi types/recursive.cmo 
 types/type_bool.cmx: types/boolean.cmx types/recursive.cmx 
-types/types.cmo: types/atoms.cmi types/boolean.cmi types/chars.cmi \
+types/types.cmo: types/atoms.cmi misc/bool.cmi types/chars.cmi \
     types/ident.cmo types/intervals.cmi types/normal.cmi types/recursive.cmo \
     types/sortedList.cmi misc/state.cmi types/types.cmi 
-types/types.cmx: types/atoms.cmx types/boolean.cmx types/chars.cmx \
+types/types.cmx: types/atoms.cmx misc/bool.cmx types/chars.cmx \
     types/ident.cmx types/intervals.cmx types/normal.cmx types/recursive.cmx \
     types/sortedList.cmx misc/state.cmx types/types.cmi 
 runtime/eval.cmo: types/atoms.cmi types/ident.cmo types/intervals.cmi \
@@ -80,10 +84,12 @@ runtime/print_xml.cmo: types/atoms.cmi types/chars.cmi types/ident.cmo \
     types/sequence.cmi runtime/value.cmi 
 runtime/print_xml.cmx: types/atoms.cmx types/chars.cmx types/ident.cmx \
     types/sequence.cmx runtime/value.cmx 
-runtime/run_dispatch.cmo: types/chars.cmi types/ident.cmo types/patterns.cmi \
-    types/types.cmi runtime/value.cmi runtime/run_dispatch.cmi 
-runtime/run_dispatch.cmx: types/chars.cmx types/ident.cmx types/patterns.cmx \
-    types/types.cmx runtime/value.cmx runtime/run_dispatch.cmi 
+runtime/run_dispatch.cmo: types/atoms.cmi types/chars.cmi types/ident.cmo \
+    types/patterns.cmi types/types.cmi runtime/value.cmi \
+    runtime/run_dispatch.cmi 
+runtime/run_dispatch.cmx: types/atoms.cmx types/chars.cmx types/ident.cmx \
+    types/patterns.cmx types/types.cmx runtime/value.cmx \
+    runtime/run_dispatch.cmi 
 runtime/value.cmo: types/atoms.cmi types/builtin.cmo types/chars.cmi \
     types/ident.cmo types/intervals.cmi types/sequence.cmi types/types.cmi \
     runtime/value.cmi 
@@ -112,7 +118,8 @@ parser/parser.cmi: parser/ast.cmo
 typing/typer.cmi: parser/ast.cmo types/ident.cmo typing/typed.cmo \
     types/types.cmi 
 types/boolean.cmi: types/sortedList.cmi 
-types/patterns.cmi: types/ident.cmo types/types.cmi 
+types/patterns.cmi: types/atoms.cmi types/chars.cmi types/ident.cmo \
+    types/types.cmi 
 types/sequence.cmi: types/atoms.cmi types/types.cmi 
 types/sortedMap.cmi: types/sortedList.cmi 
 types/syntax.cmi: types/patterns.cmi types/types.cmi 

misc/bool.ml

+type 'a obj = { id : int; mutable v : 'a }
+
+type 'a t =
+  | True
+  | False
+  | Split of 'a obj * 'a t * 'a t * 'a t
+
+let rec equal a b =
+  (a == b) ||
+  match (a,b) with
+    | Split (x1, p1,i1,n1), Split (x2, p2,i2,n2) ->
+	(x1.id = x2.id) && (equal p1 p2) & (equal i1 i2) &&
+	(equal n1 n2)
+    | _ -> false
+
+let rec compare a b =
+  if (a == b) then 0 
+  else match (a,b) with
+    | Split (x1, p1,i1,n1), Split (x2, p2,i2,n2) ->
+	if x1.id < x2.id then -1 
+	else if x1.id > x2.id then 1
+	else let c = compare p1 p2 in if c <> 0 then c
+	else let c = compare i1 i2 in if c <> 0 then c 
+	else compare n1 n2
+    | True,_  -> -1
+    | _, True -> 1
+    | False,_ -> -1
+    | _,False -> 1
+
+let rec hash = function
+  | True -> 1
+  | False -> 2
+  | Split (x, p,i,n) -> 
+      x.id + 17 * (hash p) + 257 * (hash i) + 16637 * (hash n)
+
+let rec iter f = function
+  | Split (x, p,i,n) -> f x.v; iter f p; iter f i; iter f n
+  | _ -> ()
+
+(* TODO: precompute hash value for Split node to have fast equality... *)
+
+(*
+let rec print f ppf = function
+  | True -> Format.fprintf ppf "True"
+  | False -> Format.fprintf ppf "False"
+  | Split (x, p,i,n) -> 
+      Format.fprintf ppf "%a(@[%a,%a,%a@])" 
+	f x.v (print f) p (print f) i (print f) n
+*)
+
+
+let rec print f ppf = function
+  | True -> Format.fprintf ppf "Any"
+  | False -> Format.fprintf ppf "Empty"
+  | Split (x, p,i, n) ->
+(*      Format.fprintf ppf "{%i}" x.id; *)
+      let flag = ref false in
+      let b () = if !flag then Format.fprintf ppf " | " else flag := true in
+      (match p with 
+	 | True -> b(); Format.fprintf ppf "%a" f x.v
+	 | False -> ()
+	 | _ -> b (); Format.fprintf ppf "%a & @[(%a)@]" f x.v (print f) p );
+      (match i with 
+	 | True -> assert false;
+	 | False -> ()
+	 | _ -> b(); print f ppf i);
+      (match n with 
+	 | True -> b (); Format.fprintf ppf "@[~%a@]" f x.v
+	 | False -> ()
+	 | _ -> b (); Format.fprintf ppf "@[~%a@] & @[(%a)@]" f x.v (print f) n)
+
+
+
+let rec dump ppf = function
+  | True -> Format.fprintf ppf "True"
+  | False -> Format.fprintf ppf "False"
+  | Split (x, p,i,n) -> 
+      Format.fprintf ppf "%i(@[%a,%a,%a@])" 
+	x.id dump p dump i dump n
+
+let rec dnf accu pos neg = function
+  | True -> (pos,neg) :: accu
+  | False -> accu
+  | Split (x, p,i,n) ->
+      let accu = dnf accu (x.v::pos) neg p in
+      let accu = dnf accu pos (x.v::neg) n in
+      let accu = dnf accu pos neg i in
+      accu
+
+let dnf x = dnf [] [] [] x
+
+let compute ~empty ~any ~cup ~cap ~diff ~atom b =
+  let rec aux = function
+    | True -> any
+    | False -> empty
+    | Split(x, p,i,n) ->
+	let p = cap (atom x.v) (aux p)
+	and i = aux i
+	and n = diff (aux p) (atom x.v) in
+	cup (cup p i) n
+  in
+  aux b
+
+(* Invariants:
+     Split (x, pos,ign,neg) ==>  (ign <> True);   
+     (pos <> False or neg <> False)
+
+   Other meaningful invariant that could be enforced:
+   - pos <> neg
+   - no ``subsumption''   --> DONE (cf below)
+*)
+
+let split x pos ign neg =
+  if ign = True then True 
+  else if (pos = False) && (neg = False) then ign
+  else Split (x, pos, ign, neg)
+
+
+let ( !! ) x = Split (x, True, False, False)
+
+let empty = False
+let any = True
+
+let rec simplify a l =
+(*  Format.fprintf Format.std_formatter "simplify %a <=" dump a;
+  List.iter (fun b ->  Format.fprintf Format.std_formatter " %a" dump b) l;
+  Format.fprintf Format.std_formatter "@\n";
+*)
+  if (a = False) then False else simpl_aux1 a [] l
+and simpl_aux1 a accu = function
+    | [] -> 
+	if accu = [] then a else
+	(match a with
+	   | True -> True
+	   | False -> assert false
+	   | Split (x,p,i,n) -> simpl_aux2 x p i n [] [] [] accu)
+    | False :: l -> simpl_aux1 a accu l
+    | True :: l -> False
+    | b :: l -> if a == b then False else simpl_aux1 a (b::accu) l
+and simpl_aux2 x p i n ap ai an = function
+  | [] -> split x (simplify p ap) (simplify i ai) (simplify n an)
+  | (Split (x2,p2,i2,n2) as b) :: l ->
+      if x2.id < x.id then 
+	simpl_aux3 x p i n ap ai an l i2
+      else if x.id < x2.id then 
+	simpl_aux2 x p i n (b :: ap) (b :: ai) (b :: an) l
+      else
+	simpl_aux2 x p i n (p2 :: i2 :: ap) (i2 :: ai) (n2 :: i2 :: an) l
+  | _ -> assert false
+and simpl_aux3 x p i n ap ai an l = function
+  | False -> simpl_aux2 x p i n ap ai an l
+  | True -> assert false
+  | Split (x2,p2,i2,n2) as b ->
+      if x2.id < x.id then 
+	simpl_aux3 x p i n ap ai an l i2
+      else if x.id < x2.id then 
+	simpl_aux2 x p i n (b :: ap) (b :: ai) (b :: an) l
+      else
+	simpl_aux2 x p i n (p2 :: i2 :: ap) (i2 :: ai) (n2 :: i2 :: an) l
+
+let split x p i n = 
+  split x (simplify p [i]) i (simplify n [i])
+
+let rec ( ++ ) a b =
+  if a == b then a 
+  else match (a,b) with
+    | True, _ | _, True -> True
+    | False, a | a, False -> a
+    | Split (x1, p1,i1,n1), Split (x2, p2,i2,n2) ->
+	if x1.id = x2.id then
+	  split x1 (p1 ++ p2) (i1 ++ i2) (n1 ++ n2)
+	else if x1.id < x2.id then
+	  split x1 p1 (i1 ++ b) n1
+	else
+	  split x2 p2 (i2 ++ a) n2
+
+
+(* TODO: optimize the cup with 3 arguments ? *)
+
+let rec ( ** ) a b =
+  if a == b then a
+  else match (a,b) with
+    | True, a | a, True -> a
+    | False, _ | _, False -> False
+    | Split (x1, p1,i1,n1), Split (x2, p2,i2,n2) ->
+	if x1.id = x2.id then
+	  split x1 
+	    ((p1 ** p2) ++ (p1 ** i2) ++ (p2 ** i1))
+	    (i1 ** i2)
+	    ((n1 ** n2) ++ (n1 ** i2) ++ (n2 ** i1))
+	else if x1.id < x2.id then
+	  split x1 (p1 ** b) (i1 ** b) (n1 ** b)
+	else
+	  split x2 (p2 ** a) (i2 ** a) (n2 ** a)
+
+let rec ( // ) a b =  
+  if a == b then False
+  else match (a,b) with
+    | False,_ | _, True -> False
+    | a, False -> a
+    | True, Split (x2, p2,i2,n2) ->
+      	let i = True // i2 in
+      	split x2 (i // p2) False (i // n2)
+    | Split (x1, p1,i1,n1), Split (x2, p2,i2,n2) ->
+      	if x1.id = x2.id then
+	  let i = i1 // i2 in
+	  split x1
+	    ((p1 // p2 // i2) ++ (i // p2))
+	    False
+	    ((n1 // n2 // i2) ++ (i // n2))
+	else if x1.id < x2.id then
+	  split x1 (p1 // b) (i1 // b) (n1 // b)
+	else
+	  let i = a // i2 in
+	  split x2 (i // p2) False (i // n2)

misc/bool.mli

+type 'a obj = { id : int; mutable v : 'a }
+
+type 'a t (* = True | False | Split of 'a obj * 'a t * 'a t * 'a t *)
+
+val equal : 'a t -> 'a t -> bool
+val compare: 'a t -> 'a t -> int
+val hash: 'a t -> int
+
+val iter: ('a -> unit) -> ('a t -> unit)
+
+val print : 
+  (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a t -> unit
+val dump : Format.formatter -> 'a t -> unit
+
+val dnf : 'a t -> ('a list * 'a list) list
+
+val compute: empty:'b -> any:'b -> cup:('b -> 'b -> 'b) 
+  -> cap:('b -> 'b -> 'b) -> diff:('b -> 'b -> 'b) ->
+  atom:('a -> 'b) -> 'a t -> 'b
+
+val empty : 'a t
+val any : 'a t
+val ( !! ) : 'a obj -> 'a t
+val ( ++ ) : 'a t -> 'a t -> 'a t
+val ( ** ) : 'a t -> 'a t -> 'a t
+val ( // ) : 'a t -> 'a t -> 'a t

tests/notes.cd

@@ -3,6 +3,7 @@ type Text = [ (Char | (Letter+ ' '* Note))* ];;
 type Letter = 'a'--'z' | 'A'--'Z';;
 type Note = <note>[ PCDATA ];;
 
+(*
 type Flow = [ (Char | <ref no=Int>[ PCDATA ])* ];;
 type Notes = [ <note no=Int>[ PCDATA ]* ];;
 type Result = <doc>[ <body>Flow <notes>Notes ];;
@@ -17,9 +18,11 @@ let fun text ( (Text,Int) -> (Flow,Notes) )
       (pre @ [<ref no=count>word] @ body, 
        [<note no=count>n] @ notes)
  | (body,_) -> (body, []);;
+*)
 
 try
 match load_xml "tests/notes.xml" with
- | x & Doc -> format x
+ | x & Doc -> [] (* format x *)
  | _ -> raise "Invalid input document"
-with _-> "Bon ca va";;
+with _ -> "Bon ca va";;
+

tests/overloading.cd

@@ -37,10 +37,13 @@ let base : Person =
 ]
 ;;
 
+
 sort base;;
 
 
-let fun contact(Person->String)
+(*
+
+let fun contact(Person -> String)
  | <person>[ _ _ ((<tel kind="work"> x) | (<email> x) | (<tel> x))] -> x
  | _ ->"no contact";;
 
@@ -75,3 +78,4 @@ transform [ base base ] with
   | _ -> [];;
 
 
+*)