[r2003-03-08 03:46:23 by cvscast] Empty log message

Original author: cvscast
Date: 2003-03-08 03:46:23+00:00

Makefile

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

depend

@@ -26,10 +26,10 @@ typing/typer.cmo: parser/ast.cmo types/builtin.cmo types/intervals.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.cmo types/sortedList.cmi types/boolean.cmi 
-types/boolean.cmx: types/recursive.cmx types/sortedList.cmx types/boolean.cmi 
+types/atoms.cmo: misc/pool.cmi types/sortedList.cmi types/atoms.cmi 
+types/atoms.cmx: misc/pool.cmx types/sortedList.cmx types/atoms.cmi 
+types/boolean.cmo: types/sortedList.cmi types/boolean.cmi 
+types/boolean.cmx: types/sortedList.cmx types/boolean.cmi 
 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 \
@@ -56,36 +56,36 @@ 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/intervals.cmi types/normal.cmi misc/pool.cmi types/recursive.cmo \
-    types/recursive_noshare.cmo types/sortedList.cmi types/sortedMap.cmi \
+types/types.cmo: types/atoms.cmi types/bdd.cmo types/boolean.cmi \
+    types/chars.cmi types/intervals.cmi types/normal.cmi misc/pool.cmi \
+    types/recursive.cmo types/sortedList.cmi types/sortedMap.cmi \
     misc/state.cmi types/types.cmi 
-types/types.cmx: types/atoms.cmx types/boolean.cmx types/chars.cmx \
-    types/intervals.cmx types/normal.cmx misc/pool.cmx types/recursive.cmx \
-    types/recursive_noshare.cmx types/sortedList.cmx types/sortedMap.cmx \
+types/types.cmx: types/atoms.cmx types/bdd.cmx types/boolean.cmx \
+    types/chars.cmx types/intervals.cmx types/normal.cmx misc/pool.cmx \
+    types/recursive.cmx types/sortedList.cmx types/sortedMap.cmx \
     misc/state.cmx types/types.cmi 
-runtime/eval.cmo: runtime/load_xml.cmi parser/location.cmi \
-    runtime/print_xml.cmo runtime/run_dispatch.cmi misc/state.cmi \
-    typing/typed.cmo types/types.cmi runtime/value.cmi runtime/eval.cmi 
-runtime/eval.cmx: runtime/load_xml.cmx parser/location.cmx \
-    runtime/print_xml.cmx runtime/run_dispatch.cmx misc/state.cmx \
-    typing/typed.cmx types/types.cmx runtime/value.cmx runtime/eval.cmi 
-runtime/load_xml.cmo: parser/location.cmi types/sortedMap.cmi types/types.cmi \
-    runtime/value.cmi runtime/load_xml.cmi 
-runtime/load_xml.cmx: parser/location.cmx types/sortedMap.cmx types/types.cmx \
-    runtime/value.cmx runtime/load_xml.cmi 
-runtime/print_xml.cmo: types/chars.cmi types/sequence.cmi types/types.cmi \
-    runtime/value.cmi 
-runtime/print_xml.cmx: types/chars.cmx types/sequence.cmx types/types.cmx \
-    runtime/value.cmx 
+runtime/eval.cmo: types/atoms.cmi types/intervals.cmi runtime/load_xml.cmi \
+    parser/location.cmi runtime/print_xml.cmo runtime/run_dispatch.cmi \
+    misc/state.cmi typing/typed.cmo runtime/value.cmi runtime/eval.cmi 
+runtime/eval.cmx: types/atoms.cmx types/intervals.cmx runtime/load_xml.cmx \
+    parser/location.cmx runtime/print_xml.cmx runtime/run_dispatch.cmx \
+    misc/state.cmx typing/typed.cmx runtime/value.cmx runtime/eval.cmi 
+runtime/load_xml.cmo: types/atoms.cmi parser/location.cmi types/sortedMap.cmi \
+    types/types.cmi runtime/value.cmi runtime/load_xml.cmi 
+runtime/load_xml.cmx: types/atoms.cmx parser/location.cmx types/sortedMap.cmx \
+    types/types.cmx runtime/value.cmx runtime/load_xml.cmi 
+runtime/print_xml.cmo: types/atoms.cmi types/chars.cmi types/sequence.cmi \
+    types/types.cmi runtime/value.cmi 
+runtime/print_xml.cmx: types/atoms.cmx types/chars.cmx types/sequence.cmx \
+    types/types.cmx runtime/value.cmx 
 runtime/run_dispatch.cmo: types/patterns.cmi types/types.cmi \
     runtime/value.cmi runtime/run_dispatch.cmi 
 runtime/run_dispatch.cmx: types/patterns.cmx types/types.cmx \
     runtime/value.cmx runtime/run_dispatch.cmi 
-runtime/value.cmo: types/chars.cmi types/sequence.cmi types/sortedMap.cmi \
-    types/types.cmi runtime/value.cmi 
-runtime/value.cmx: types/chars.cmx types/sequence.cmx types/sortedMap.cmx \
-    types/types.cmx runtime/value.cmi 
+runtime/value.cmo: types/atoms.cmi types/chars.cmi types/intervals.cmi \
+    types/sequence.cmi types/sortedMap.cmi types/types.cmi runtime/value.cmi 
+runtime/value.cmx: types/atoms.cmx types/chars.cmx types/intervals.cmx \
+    types/sequence.cmx types/sortedMap.cmx types/types.cmx runtime/value.cmi 
 driver/cduce.cmo: parser/ast.cmo types/builtin.cmo runtime/eval.cmi \
     parser/location.cmi parser/parser.cmi types/patterns.cmi misc/state.cmi \
     typing/typed.cmo typing/typer.cmi types/types.cmi runtime/value.cmi \
@@ -94,8 +94,10 @@ driver/cduce.cmx: parser/ast.cmx types/builtin.cmx runtime/eval.cmx \
     parser/location.cmx parser/parser.cmx types/patterns.cmx misc/state.cmx \
     typing/typed.cmx typing/typer.cmx types/types.cmx runtime/value.cmx \
     parser/wlexer.cmx driver/cduce.cmi 
-driver/run.cmo: driver/cduce.cmi parser/location.cmi misc/state.cmi 
-driver/run.cmx: driver/cduce.cmx parser/location.cmx misc/state.cmx 
+driver/run.cmo: driver/cduce.cmi parser/location.cmi misc/state.cmi \
+    types/types.cmi 
+driver/run.cmx: driver/cduce.cmx parser/location.cmx misc/state.cmx \
+    types/types.cmx 
 driver/webiface.cmo: driver/cduce.cmi driver/examples.cmo parser/location.cmi \
     misc/state.cmi 
 driver/webiface.cmx: driver/cduce.cmx driver/examples.cmx parser/location.cmx \
@@ -107,7 +109,7 @@ typing/typer.cmi: parser/ast.cmo typing/typed.cmo types/types.cmi
 types/boolean.cmi: types/sortedList.cmi 
 types/normal.cmi: types/boolean.cmi 
 types/patterns.cmi: types/sortedList.cmi types/sortedMap.cmi types/types.cmi 
-types/sequence.cmi: 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 
 types/types.cmi: types/atoms.cmi types/chars.cmi types/intervals.cmi \
@@ -115,5 +117,6 @@ types/types.cmi: types/atoms.cmi types/chars.cmi types/intervals.cmi \
 runtime/eval.cmi: typing/typed.cmo runtime/value.cmi 
 runtime/load_xml.cmi: runtime/value.cmi 
 runtime/run_dispatch.cmi: types/patterns.cmi runtime/value.cmi 
-runtime/value.cmi: types/chars.cmi types/sortedMap.cmi types/types.cmi 
+runtime/value.cmi: types/atoms.cmi types/chars.cmi types/intervals.cmi \
+    types/sortedMap.cmi types/types.cmi 
 driver/cduce.cmi: runtime/eval.cmi typing/typer.cmi 

driver/cduce.ml

@@ -83,6 +83,12 @@ let rec print_exn ppf = function
 *)
 
 let debug ppf = function
+  | `Subtype (t1,t2) ->
+      Format.fprintf ppf "[DEBUG:subtype]@\n";
+      let t1 = Types.descr (Typer.typ !glb_env t1)
+      and t2 = Types.descr (Typer.typ !glb_env t2) in
+      Format.fprintf ppf "%a <= %a : %b@\n" print_norm t1 print_norm t2
+	(Types.subtype t1 t2)
   | `Filter (t,p) -> 
       Format.fprintf ppf "[DEBUG:filter]@\n";
       let t = Typer.typ !glb_env t

parser/ast.ml

@@ -18,6 +18,7 @@ and debug_directive =
   | `Compile of ppat * ppat list 
   | `Normal_record of ppat
   | `Compile2 of ppat * ppat list
+  | `Subtype of ppat * ppat
   ]
 
 

parser/parser.ml

@@ -78,6 +78,7 @@ EXTEND
     | LIDENT "compile"; t = pat; p = LIST1 pat -> `Compile (t,p)
     | LIDENT "normal_record"; t = pat -> `Normal_record t
     | LIDENT "compile2"; t = pat; p = LIST1 pat -> `Compile2 (t,p)
+    | LIDENT "subtype"; t1 = pat; t2 = pat -> `Subtype (t1,t2)
     ]
   ];
 

types/atoms.ml

@@ -10,7 +10,14 @@ type v = AtomPool.t
 let value = AtomPool.value
 let mk = AtomPool.mk
 
-type t = Finite of v list | Cofinite of v list
+module SList = SortedList.Make(
+  struct 
+    type 'a t = v 
+    let compare = AtomPool.compare 
+    let hash = AtomPool.hash 
+    let equal = AtomPool.equal 
+  end)
+type t = Finite of unit SList.t | Cofinite of unit SList.t
 
 let empty = Finite []
 let any   = Cofinite []
@@ -19,28 +26,28 @@ let atom x = Finite [x]
 
 let cup s t =
   match (s,t) with
-    | (Finite s, Finite t) -> Finite (SortedList.cup s t)
-    | (Finite s, Cofinite t) -> Cofinite (SortedList.diff t s)
-    | (Cofinite s, Finite t) -> Cofinite (SortedList.diff s t)
-    | (Cofinite s, Cofinite t) -> Cofinite (SortedList.cap s t)
+    | (Finite s, Finite t) -> Finite (SList.cup s t)
+    | (Finite s, Cofinite t) -> Cofinite (SList.diff t s)
+    | (Cofinite s, Finite t) -> Cofinite (SList.diff s t)
+    | (Cofinite s, Cofinite t) -> Cofinite (SList.cap s t)
 
 let cap s t =
   match (s,t) with
-    | (Finite s, Finite t) -> Finite (SortedList.cap s t)
-    | (Finite s, Cofinite t) -> Finite (SortedList.diff s t)
-    | (Cofinite s, Finite t) -> Finite (SortedList.diff t s)
-    | (Cofinite s, Cofinite t) -> Cofinite (SortedList.cup s t)
+    | (Finite s, Finite t) -> Finite (SList.cap s t)
+    | (Finite s, Cofinite t) -> Finite (SList.diff s t)
+    | (Cofinite s, Finite t) -> Finite (SList.diff t s)
+    | (Cofinite s, Cofinite t) -> Cofinite (SList.cup s t)
 
 let diff s t =
   match (s,t) with
-    | (Finite s, Cofinite t) -> Finite (SortedList.cap s t)
-    | (Finite s, Finite t) -> Finite (SortedList.diff s t)
-    | (Cofinite s, Cofinite t) -> Finite (SortedList.diff t s)
-    | (Cofinite s, Finite t) -> Cofinite (SortedList.cup s t)
+    | (Finite s, Cofinite t) -> Finite (SList.cap s t)
+    | (Finite s, Finite t) -> Finite (SList.diff s t)
+    | (Cofinite s, Cofinite t) -> Finite (SList.diff t s)
+    | (Cofinite s, Finite t) -> Cofinite (SList.cup s t)
 	
 let contains x = function
-  | Finite s -> SortedList.mem s x
-  | Cofinite s -> not (SortedList.mem s x)
+  | Finite s -> SList.mem s x
+  | Cofinite s -> not (SList.mem s x)
 
 let is_empty = function
   | Finite [] -> true
@@ -74,6 +81,8 @@ let print = function
 	  List.iter (fun x -> Format.fprintf ppf " |@ %a" print_v x) t;
 	  Format.fprintf ppf ")@]" ]
 
+
+(* TODO: clean what follow to re-use SList operations *)
 let rec hash_seq accu = function
   | t::rem -> hash_seq (accu * 17 + t) rem
   | [] -> accu
@@ -93,3 +102,4 @@ let equal t1 t2 = match (t1,t2) with
   | (Cofinite l1, Cofinite l2) -> equal_rec l1 l2
   | _ -> false
   
+

types/boolean.ml

-type 'a t = ('a list * 'a list) list
+module type S =
+sig
+  type 'a elem
+  type 'a t
+
+  val equal : 'a t -> 'a t -> bool
+  val compare: 'a t -> 'a t -> int
+  val hash: 'a t -> int
+
+  external get: 'a t -> ('a elem list * 'a elem list) list = "%identity"
+
+  val empty : 'a t
+  val full  : '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 elem -> 'a t
+
+  val map : ('a elem-> 'b elem) -> 'a t -> 'b t
+  val iter: ('a elem-> unit) -> 'a t -> unit
+  val compute: empty:'d -> full:'c -> cup:('d -> 'c -> 'd) 
+    -> cap:('c -> 'b -> 'c) -> diff:('c -> 'b -> 'c) ->
+    atom:('a elem -> 'b) -> 'a t -> 'd
+  val compute_bool: ('a elem -> 'b t) -> 'a t -> 'b t
+    
+  val print: string -> (Format.formatter -> 'a elem -> unit) -> 'a t ->
+    (Format.formatter -> unit) list
+    
+    
+  val check: 'a t -> unit
+end
+
+module Make(X : SortedList.ARG) = struct
+  type 'a elem = 'a X.t
+  module SList = SortedList.Make(X)
+  module SSList = SortedList.Make
+    (struct
+       type 'a t = 'a SList.t * 'a SList.t
+       let compare (x1,y1) (x2,y2) =
+	 let c = SList.compare x1 x2 in if c <> 0 then c
+	 else SList.compare y1 y2
+       let equal (x1,y1) (x2,y2) =
+	 (SList.equal x1 x2) && (SList.equal y1 y2)
+       let hash (x,y) =
+	 SList.hash x + 17 * SList.hash y
+     end)
+  type 'a t = 'a SSList.t
+  let hash = SSList.hash
+  let compare = SSList.compare
+  let equal = SSList.equal
+
+  external get: 'a t -> ('a elem list * 'a elem list) list = "%identity"
+
 
 let empty = [ ]
 
@@ -7,7 +59,7 @@ let full  = [ ([],[]) ]
 let atom x = [ ([x],[]) ]
 
 let may_remove (p1,n1) (p2,n2) =
-  (SortedList.subset p2 p1) && (SortedList.subset n2 n1)
+  (SList.subset p2 p1) && (SList.subset n2 n1)
 
 let cup t s = 
   if t == s then t
@@ -18,7 +70,7 @@ let cup t s =
       List.filter (fun (p,n) -> not (List.exists (may_remove (p,n)) t)) s in
     let t=
       List.filter (fun (p,n) -> not (List.exists (may_remove (p,n)) s)) t in 
-    SortedList.cup s t
+    SSList.cup s t
 
 let tot = ref 0
 let clean accu t =
@@ -30,7 +82,7 @@ let clean accu t =
 	else aux ((p,n)::accu) rem 
     | [] -> accu
   in
-  SortedList.from_list (aux accu t)
+  SSList.from_list (aux accu t)
 
 
     
@@ -50,10 +102,10 @@ let cap s t =
   else if t == full then s
   else if (s == empty) || (t == empty) then empty
   else
-    let (lines1,common,lines2) = SortedList.split s t in
+    let (lines1,common,lines2) = SSList.split s t in
     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
+        if (SList.disjoint p1 n2) && (SList.disjoint p2 n1) 
+        then (SList.cup p1 p2, SList.cup n1 n2) :: lines
 	else lines
     in
     clean common (fold2 aux [] lines1 lines2)
@@ -62,11 +114,11 @@ let diff c1 c2 =
   if c2 == full then empty
   else if (c1 == empty) || (c2 == empty) then c1
   else
-    let c1 = SortedList.diff c1 c2 in
+    let c1 = SSList.diff c1 c2 in
     let line (p,n) =
       let acc = List.fold_left (fun acc a -> ([], [a]) :: acc) [] p in
       let acc = List.fold_left (fun acc a -> ([a], []) :: acc) acc n in
-      SortedList.from_list acc
+      SSList.from_list acc
     in
     List.fold_left (fun c1 l -> cap c1 (line l)) c1 c2
 
@@ -75,12 +127,12 @@ let rec map f t =
   let lines =
     List.fold_left
       (fun lines (p,n) ->
-	 let p = SortedList.map f p and n = SortedList.map f n in
-	 if (SortedList.disjoint p n) then (p,n) :: lines else lines)
+	 let p = SList.map f p and n = SList.map f n in
+	 if (SList.disjoint p n) then (p,n) :: lines else lines)
       []
       t
   in
-  SortedList.from_list lines
+  SSList.from_list lines
 
 let iter f t =
   List.iter (fun (p,n) -> List.iter f p; List.iter f n) t
@@ -119,12 +171,21 @@ let print any f =
     )
 
 let check b =
-  SortedList.check b;
+  SSList.check b;
   List.iter 
     (fun (p,n) -> 
-       SortedList.check p; 
-       SortedList.check n; 
-       assert (SortedList.disjoint p n)
+       SList.check p; 
+       SList.check n; 
+       assert (SList.disjoint p n)
     )
     b
 
+end
+
+include Make(
+  struct 
+    type 'a t = 'a 
+    let hash = Hashtbl.hash 
+    let equal x y = x = y 
+    let compare = compare 
+  end)

types/boolean.mli

@@ -10,26 +10,38 @@
    (w.r.t Pervasives.compare).
 *)
 
-   
-
-type 'a t = ('a SortedList.t * 'a SortedList.t) SortedList.t
-
-val empty : 'a t
-val full  : '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
-
-val map : ('a -> 'b) -> 'a t -> 'b t
-val iter: ('a -> unit) -> 'a t -> unit
-val compute: empty:'d -> full:'c -> cup:('d -> 'c -> 'd) 
-	    -> cap:('c -> 'b -> 'c) -> diff:('c -> 'b -> 'c) ->
-            atom:('a -> 'b) -> 'a t -> 'd
-val compute_bool: ('a -> 'b t) -> 'a t -> 'b t
-
-val print: string -> (Format.formatter -> 'a -> unit) -> 'a t ->
-  (Format.formatter -> unit) list
-
-
-val check: 'a t -> unit
+module type S =
+sig
+  type 'a elem
+  type 'a t 
+
+  val equal : 'a t -> 'a t -> bool
+  val compare: 'a t -> 'a t -> int
+  val hash: 'a t -> int
+
+  external get: 'a t -> ('a elem list * 'a elem list) list = "%identity"
+
+  val empty : 'a t
+  val full  : '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 elem -> 'a t
+
+  val map : ('a elem-> 'b elem) -> 'a t -> 'b t
+  val iter: ('a elem-> unit) -> 'a t -> unit
+  val compute: empty:'d -> full:'c -> cup:('d -> 'c -> 'd) 
+    -> cap:('c -> 'b -> 'c) -> diff:('c -> 'b -> 'c) ->
+    atom:('a elem -> 'b) -> 'a t -> 'd
+  val compute_bool: ('a elem -> 'b t) -> 'a t -> 'b t
+    
+  val print: string -> (Format.formatter -> 'a elem -> unit) -> 'a t ->
+    (Format.formatter -> unit) list
+    
+    
+  val check: 'a t -> unit
+end
+
+module Make(X : SortedList.ARG) : S with type 'a elem = 'a X.t
+
+include S with type 'a elem = 'a and type 'a t = ('a list * 'a list) list

types/sortedList.ml

-type 'a t = 'a list
+module type ARG = sig
+  type 'a t
+  val equal: 'a t -> 'a t -> bool
+  val hash: 'a t -> int
+  val compare: 'a t -> 'a t -> int
+end
+
+module type S =
+sig
+  type 'a elem
+  type 'a t
+  val equal: 'a t -> 'a t -> bool
+  val hash: 'a t -> int
+  val compare: 'a t -> 'a t -> int
+
+  val from_list : 'a elem list -> 'a t
+  val add: 'a elem -> 'a t -> 'a t
+  val disjoint: 'a t -> 'a t -> bool
+  val cup: 'a t -> 'a t -> 'a t
+  val split: 'a t -> 'a t -> 'a t * 'a t * 'a t
+    (* split l1 l2 = (l1 \ l2, l1 & l2, l2 \ l1) *)
+  val cap:  'a t -> 'a t -> 'a t
+  val diff: 'a t -> 'a t -> 'a t
+  val subset: 'a t -> 'a t -> bool
+  val map: ('a elem-> 'b elem) -> 'a t -> 'b t
+  val mem: 'a t -> 'a elem -> bool
+
+  val check: 'a elem list -> unit
+end
+
+module Make(X : ARG) = struct
+
+  type 'a t = 'a X.t list
+  type 'a elem = 'a X.t
+
+  let rec equal l1 l2 =
+    (l1 == l2) ||
+    match (l1,l2) with
+      | x1::l1, x2::l2 -> (X.equal x1 x2) && (equal l1 l2)
+      | _ -> false
+
+  let rec hash accu = function
+    | [] -> 1 + accu
+    | x::l -> hash (17 * accu + X.hash x) l
+
+  let hash l = hash 1 l
+
+  let rec compare l1 l2 =
+    if l1 == l2 then 0 
+    else match (l1,l2) with
+      | x1::l1, x2::l2 -> 
+	  let c = X.compare x1 x2 in if c <> 0 then c 
+	  else compare l1 l2
+      | [],_ -> -1
+      | _ -> 1
+
 
 let rec disjoint l1 l2 =
   match (l1,l2) with
     | (t1::q1, t2::q2) -> 
-	let c = compare t1 t2 in
+	let c = X.compare t1 t2 in
 	if c < 0 then disjoint q1 l2
 	else if c > 0 then disjoint l1 q2
 	else false
@@ -12,7 +67,7 @@ let rec disjoint l1 l2 =
 let rec cup l1 l2 =
   match (l1,l2) with
     | (t1::q1, t2::q2) ->
-	let c = compare t1 t2 in
+	let c = X.compare t1 t2 in
 	if c = 0 then t1::(cup q1 q2)
 	else if c < 0 then t1::(cup q1 l2)
 	else t2::(cup l1 q2)
@@ -24,7 +79,7 @@ let add x l = cup [x] l
 let rec split l1 l2 =
   match (l1,l2) with
     | (t1::q1, t2::q2) ->
-	let c = compare t1 t2 in
+	let c = X.compare t1 t2 in
 	if c = 0 then       let (l1,i,l2) = split q1 q2 in (l1,t1::i,l2)
 	else if c < 0 then  let (l1,i,l2) = split q1 l2 in (t1::l1,i,l2)
 	else                let (l1,i,l2) = split l1 q2 in (l1,i,t2::l2)
@@ -34,7 +89,7 @@ let rec split l1 l2 =
 let rec diff l1 l2 =
   match (l1,l2) with
     | (t1::q1, t2::q2) ->
-	let c = compare t1 t2 in
+	let c = X.compare t1 t2 in
 	if c = 0 then diff q1 q2
 	else if c < 0 then t1::(diff q1 l2)
 	else diff l1 q2
@@ -43,7 +98,7 @@ let rec diff l1 l2 =
 let rec cap l1 l2 =
   match (l1,l2) with
     | (t1::q1, t2::q2) ->
-	let c = compare t1 t2 in
+	let c = X.compare t1 t2 in
 	if c = 0 then t1::(cap q1 q2)
 	else if c < 0 then cap q1 l2
 	else cap l1 q2
@@ -53,7 +108,7 @@ let rec cap l1 l2 =
 let rec subset l1 l2 =
   match (l1,l2) with
     | (t1::q1, t2::q2) ->
-	let c = compare t1 t2 in
+	let c = X.compare t1 t2 in
 	if c = 0 then subset q1 q2
 	else if c < 0 then false
 	else subset l1 q2
@@ -82,9 +137,20 @@ let rec mem l x =
   match l with
     | [] -> false
     | t::q -> 
-        let c = compare x t in
+        let c = X.compare x t in
         (c = 0) || ((c > 0) && (mem q x))
 
 let rec check = function
-  | a::(b::_ as t) -> assert (a < b); check t
+  | a::(b::_ as t) -> assert (X.compare a b < 0); check t
   | _ -> ()
+
+end
+
+
+include Make(
+  struct 
+    type 'a t = 'a 
+    let hash = Hashtbl.hash 
+    let equal x y = x = y 
+    let compare = compare 
+  end)

types/sortedList.mli

 (* Sorted list without duplicates.
    Comparisons between elements are done by Pervasives.compare *)
 
-type 'a t = 'a list
-val from_list : 'a list -> 'a t
-val add: 'a -> 'a t -> 'a t
-val disjoint: 'a t -> 'a t -> bool
-val cup: 'a t -> 'a t -> 'a t
-val split: 'a t -> 'a t -> 'a t * 'a t * 'a t
+module type ARG =
+sig
+    type 'a t
+    val equal: 'a t -> 'a t -> bool
+    val hash: 'a t -> int
+    val compare: 'a t -> 'a t -> int
+end
+
+module type S =
+sig
+  type 'a elem
+  type 'a t
+  val equal: 'a t -> 'a t -> bool
+  val hash: 'a t -> int
+  val compare: 'a t -> 'a t -> int
+
+  val from_list : 'a elem list -> 'a t
+  val add: 'a elem -> 'a t -> 'a t
+  val disjoint: 'a t -> 'a t -> bool
+  val cup: 'a t -> 'a t -> 'a t
+  val split: 'a t -> 'a t -> 'a t * 'a t * 'a t
     (* split l1 l2 = (l1 \ l2, l1 & l2, l2 \ l1) *)
-val cap:  'a t -> 'a t -> 'a t
-val diff: 'a t -> 'a t -> 'a t
-val subset: 'a t -> 'a t -> bool
-val map: ('a -> 'b) -> 'a t -> 'b t
-val mem: 'a t -> 'a -> bool
+  val cap:  'a t -> 'a t -> 'a t
+  val diff: 'a t -> 'a t -> 'a t
+  val subset: 'a t -> 'a t -> bool
+  val map: ('a elem-> 'b elem) -> 'a t -> 'b t
+  val mem: 'a t -> 'a elem -> bool
+
+  val check: 'a elem list -> unit
+end
 
+module Make(X : ARG) : S with type 'a elem = 'a X.t and type 'a t = 'a X.t list
 
-val check: 'a list -> unit
+include S with type 'a elem = 'a and type 'a t = 'a list