[r2002-10-31 17:35:39 by cvscast] Empty log message

Original author: cvscast
Date: 2002-10-31 17:36:04+00:00

Makefile

@@ -8,7 +8,8 @@ PARSER = parser/lexer.cmo parser/location.cmo parser/ast.cmo parser/parser.cmo
 
 TYPING = typing/typed.cmo typing/typer.cmo
 
-TYPES  = types/recursive.cmo types/sortedList.cmo \
+TYPES  = types/recursive.cmo types/recursive_share.cmo types/recursive_noshare.cmo \
+         types/sortedList.cmo \
          types/sortedMap.cmo types/boolean.cmo \
          types/intervals.cmo types/chars.cmo types/atoms.cmo \
          types/types.cmo \

depend

@@ -12,18 +12,20 @@ typing/typed.cmo: parser/location.cmi types/patterns.cmi types/sortedMap.cmi \
     types/types.cmi 
 typing/typed.cmx: parser/location.cmx types/patterns.cmx types/sortedMap.cmx \
     types/types.cmx 
-typing/typer.cmo: parser/ast.cmo types/intervals.cmi parser/location.cmi \
-    types/patterns.cmi types/sequence.cmi types/sortedList.cmi \
-    typing/typed.cmo types/types.cmi typing/typer.cmi 
-typing/typer.cmx: parser/ast.cmx types/intervals.cmx parser/location.cmx \
-    types/patterns.cmx types/sequence.cmx types/sortedList.cmx \
-    typing/typed.cmx types/types.cmx typing/typer.cmi 
+typing/typer.cmo: parser/ast.cmo types/builtin.cmo types/intervals.cmi \
+    parser/location.cmi types/patterns.cmi types/sequence.cmi \
+    types/sortedList.cmi typing/typed.cmo types/types.cmi typing/typer.cmi 
+typing/typer.cmx: parser/ast.cmx types/builtin.cmx types/intervals.cmx \
+    parser/location.cmx types/patterns.cmx types/sequence.cmx \
+    types/sortedList.cmx typing/typed.cmx types/types.cmx typing/typer.cmi 
 types/atoms.cmo: types/sortedList.cmi types/atoms.cmi 
 types/atoms.cmx: types/sortedList.cmx types/atoms.cmi 
-types/boolean.cmo: types/recursive.cmi types/sortedList.cmi types/boolean.cmi 
+types/boolean.cmo: types/recursive.cmo types/sortedList.cmi types/boolean.cmi 
 types/boolean.cmx: types/recursive.cmx types/sortedList.cmx types/boolean.cmi 
-types/builtin.cmo: types/atoms.cmi types/chars.cmi types/types.cmi 
-types/builtin.cmx: types/atoms.cmx types/chars.cmx types/types.cmx 
+types/builtin.cmo: types/atoms.cmi types/chars.cmi types/sequence.cmi \
+    types/types.cmi 
+types/builtin.cmx: types/atoms.cmx types/chars.cmx types/sequence.cmx \
+    types/types.cmx 
 types/chars.cmo: types/chars.cmi 
 types/chars.cmx: types/chars.cmi 
 types/intervals.cmo: types/intervals.cmi 
@@ -32,26 +34,28 @@ types/patterns.cmo: types/sortedList.cmi types/sortedMap.cmi types/types.cmi \
     types/patterns.cmi 
 types/patterns.cmx: types/sortedList.cmx types/sortedMap.cmx types/types.cmx \
     types/patterns.cmi 
-types/recursive.cmo: types/recursive.cmi 
-types/recursive.cmx: types/recursive.cmi 
+types/recursive_noshare.cmo: types/recursive.cmo 
+types/recursive_noshare.cmx: types/recursive.cmx 
+types/recursive_share.cmo: types/recursive.cmo 
+types/recursive_share.cmx: types/recursive.cmx 
 types/sequence.cmo: types/atoms.cmi types/types.cmi types/sequence.cmi 
 types/sequence.cmx: types/atoms.cmx types/types.cmx types/sequence.cmi 
 types/sortedList.cmo: types/sortedList.cmi 
 types/sortedList.cmx: types/sortedList.cmi 
 types/sortedMap.cmo: types/sortedMap.cmi 
 types/sortedMap.cmx: types/sortedMap.cmi 
-types/strings.cmo: types/boolean.cmi types/intervals.cmi types/recursive.cmi \
+types/strings.cmo: types/boolean.cmi types/intervals.cmi types/recursive.cmo \
     types/strings.cmi 
 types/strings.cmx: types/boolean.cmx types/intervals.cmx types/recursive.cmx \
     types/strings.cmi 
-types/type_bool.cmo: types/boolean.cmi types/recursive.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/intervals.cmi types/recursive.cmi types/sortedList.cmi \
-    types/sortedMap.cmi types/types.cmi 
+    types/intervals.cmi types/recursive.cmo types/recursive_share.cmo \
+    types/sortedList.cmi types/sortedMap.cmi types/types.cmi 
 types/types.cmx: types/atoms.cmx types/boolean.cmx types/chars.cmx \
-    types/intervals.cmx types/recursive.cmx types/sortedList.cmx \
-    types/sortedMap.cmx types/types.cmi 
+    types/intervals.cmx types/recursive.cmx types/recursive_share.cmx \
+    types/sortedList.cmx types/sortedMap.cmx types/types.cmi 
 runtime/value.cmo: types/chars.cmi types/patterns.cmi types/sequence.cmi \
     types/sortedMap.cmi typing/typed.cmo types/types.cmi runtime/value.cmi 
 runtime/value.cmx: types/chars.cmx types/patterns.cmx types/sequence.cmx \

driver/cduce.ml

@@ -24,7 +24,7 @@ let prog () =
     | Stdpp.Exc_located (loc, e) -> raise (Location (loc, e))
 
 let print_norm ppf d = 
-  Types.Print.print_descr ppf (Types.normalize d)
+  Types.Print.print_descr ppf ((*Types.normalize*) d)
 
 let rec print_exn ppf = function
   | Location (loc, exn) ->

tests/bib.xml

+<?xml version="1.0" standalone="yes"?>
+<bib>
+  <book>
+    <title>Persistent Object Systems</title>
+    <year>1994</year>
+    <author>M. Atkinson</author>
+    <author>V. Benzaken</author>
+    <author>D. Maier</author>
+  </book> 
+  <book>
+    <title>OOP: a unified foundation</title>
+    <year>1997</year>
+    <author>G. Castagna</author>
+  </book>
+</bib>

tests/wp.cd

@@ -59,3 +59,9 @@ type Flat = [ (Title Year Author+)* ];;
 let fun flatten_bib (l : [Book*]) : Flat =
     transform l with <book>x -> x;;
 
+type Chair_auth = <author>['Pierce'|'Wadler'];;
+type Chair = <book>[_* Chair_auth _*];;
+
+let fun chair_books (Bib -> [(Chair & Book)*])
+ <bib>[(b::Chair | _)*] -> b;;
+

types/recursive.ml

-(* A fast replacement of Recursive without sharing at all *)
-
 exception NotEqual
 exception Incomplete
 
@@ -9,51 +7,41 @@ sig
   val map: ('a -> 'b) -> ('a t -> 'b t)
 
   val equal: ('a -> 'a -> unit) -> ('a t -> 'a t -> unit)
+      (* equal checks that two terms are equal and raises NotEqual otherwise;
+	 the first argument must be called to check equality of subterms *)
+
   val iter: ('a -> unit) -> ('a t -> unit)
+      (* a valid definition is often: 
+	 let iter f a = ignore (map f a) *)
+      
   val hash: ('a -> int) -> ('a t -> int)
-
+      (* [hash] should behave correctly w.r.t [map], that is:
+	 hash h (map f a) == hash (h \circ f) a
+	 
+	 A valid definition is often:
+	 let hash h a = Hashtbl.hash (map h a)
+      *)
+      
   val deep: int
+      (* specify the deepness of hashing; use a value large enough to
+	 discriminate between most non-equivalent graphs;
+	 deep = 3 or 4 may often be adequate. *)
 end
 
+module type Make = functor (X : S) ->
+sig 
+  type node
+  type descr = node X.t
 
-module Make(X : S) = 
-struct
-  type state = Undefined | Defined
-
-  type node = { 
-    id : int; 
-    mutable descr : descr;
-  }
-  and descr = node X.t
-
-  let id n = n.id
-
-  let counter = ref 0
-
-  let make () =
-    incr counter;
-    { 
-      id = !counter;
-      descr = Obj.magic 0;
-    }
-
-  let equal x y = x.id = y.id
-
-
-  let internalize n = n
-  let internalize_descr d = d
+  val make: unit -> node
+  val define: node -> descr -> unit
 
-  let descr n = n.descr
+  val internalize: node -> node
+  val internalize_descr: descr -> descr
 
-  let define n d = n.descr <- d
+  val id: node -> int
+  val descr: node -> descr
 
-  let hash_descr d =  X.hash (fun n -> n.id) d
-  let equal_descr d1 d2 =
-    (d1 == d2) ||
-    try 
-      X.equal 
-      	(fun n1 n2 -> if n1.id <> n2.id then raise NotEqual) 
-	d1 d2; 
-      true
-    with NotEqual -> false
+  val hash_descr: descr -> int
+  val equal_descr: descr -> descr -> bool
 end

types/recursive.mli

-(* $Id: recursive.mli,v 1.3 2002/10/17 15:38:34 cvscast Exp $ *)
-
-exception NotEqual
-exception Incomplete
-
-module type S = 
-sig
-  type 'a t
-  val map: ('a -> 'b) -> ('a t -> 'b t)
-
-  val equal: ('a -> 'a -> unit) -> ('a t -> 'a t -> unit)
-      (* equal checks that two terms are equal and raises NotEqual otherwise;
-	 the first argument must be called to check equality of subterms *)
-
-  val iter: ('a -> unit) -> ('a t -> unit)
-      (* a valid definition is often: 
-	 let iter f a = ignore (map f a) *)
-      
-  val hash: ('a -> int) -> ('a t -> int)
-      (* [hash] should behave correctly w.r.t [map], that is:
-	 hash h (map f a) == hash (h \circ f) a
-	 
-	 A valid definition is often:
-	 let hash h a = Hashtbl.hash (map h a)
-      *)
-      
-  val deep: int
-      (* specify the deepness of hashing; use a value large enough to
-	 discriminate between most non-equivalent graphs;
-	 deep = 3 or 4 may often be adequate. *)
-end
-
-module Make(X : S) : 
-sig 
-  type node
-  type descr = node X.t
-
-  val make: unit -> node
-  val define: node -> descr -> unit
-
-  val internalize: node -> node
-  val internalize_descr: descr -> descr
-
-  val id: node -> int
-  val descr: node -> descr
-
-  val hash_descr: descr -> int
-  val equal_descr: descr -> descr -> bool
-end
-

types/recursive_noshare.ml

 (* A fast replacement of Recursive without sharing at all *)
-
-exception NotEqual
-exception Incomplete
-
-module type S = 
-sig
-  type 'a t
-  val map: ('a -> 'b) -> ('a t -> 'b t)
-
-  val equal: ('a -> 'a -> unit) -> ('a t -> 'a t -> unit)
-  val iter: ('a -> unit) -> ('a t -> unit)
-  val hash: ('a -> int) -> ('a t -> int)
-
-  val deep: int
-end
-
+open Recursive
 
 module Make(X : S) = 
 struct

types/recursive_share.ml

-(* $Id: recursive_share.ml,v 1.1 2002/10/30 02:05:42 cvscast Exp $ *)
-
-exception NotEqual
-exception Incomplete
-
-module type S = 
-sig
-  type 'a t
-  val map: ('a -> 'b) -> ('a t -> 'b t)
-
-  val equal: ('a -> 'a -> unit) -> ('a t -> 'a t -> unit)
-  val iter: ('a -> unit) -> ('a t -> unit)
-  val hash: ('a -> int) -> ('a t -> int)
-
-  val deep: int
-end
-
+(* $Id: recursive_share.ml,v 1.2 2002/10/31 17:35:39 cvscast Exp $ *)
+open Recursive
 
 module Make(X : S) = 
 struct

types/types.ml

@@ -112,7 +112,7 @@ module I = struct
 end
 
 	     
-module Algebra = Recursive.Make(I)
+module Algebra = Recursive_noshare.Make(I)
 include I
 include Algebra