- Saner version of string comparisons.

 - Properly check for unbound type variables in type definitions.

misc/custom.ml

@@ -37,6 +37,7 @@ module String : T with type t = string = struct
   let dump = Format.pp_print_string
   let check s = ()
 
+		  (*
   let rec compare_string_aux s1 s2 l =
     if (l == 0) then 0 
     else
@@ -48,7 +49,8 @@ module String : T with type t = string = struct
   let compare s1 s2 =
     let l1 = String.length s1 and l2 = String.length s2 in
     if l1 != l2 then l2 - l1 else compare_string_aux s1 s2 l1
-
+		   *)
+  let compare = String.compare
 
   let equal x y = compare x y = 0
 

types/var.ml

@@ -16,11 +16,16 @@ module V = struct
     Format.fprintf ppf "%a(%d_%a)" Ident.U.print t.name t.id print_kind t.kind
 
   let compare x y =
+
     let c = compare_kind x.kind y.kind in
     if c == 0 then
+      let c = Ident.U.compare x.name y.name in
+      if c == 0 then Pervasives.compare x.id y.id else
+	c
+    (*
       let c = Pervasives.compare x.id y.id in
       if c == 0 then Ident.U.compare x.name y.name
-      else c
+      else c *)
     else c
 
   let equal x y =

typing/typer.ml

@@ -157,7 +157,7 @@ let find_id env0 env loc head x =
       raise_loc loc (UnboundCompUnit x)
 
 let find_id_comp env0 env loc head x =
-  let l2 = 
+  let l2 =
     if ((match (U.get_str x).[0] with 'A'..'Z' -> true | _ -> false)
 	&& !has_ocaml_unit x)
     then [ EOCaml (U.get_str x) ]
@@ -680,11 +680,20 @@ let  invalid_instance_error loc s =
             ("This definition yields an empty type for " ^ (Ident.to_string v));
 
         let vars_rhs = Types.all_vars t_rhs in
-        if List.exists (fun x -> not (Var.Set.mem vars_rhs (Var.mk (U.to_string x)) )) args then
-          raise_loc_generic loc
-            (Printf.sprintf "Definition of type %s contains unbound type variables"
-               (Ident.to_string v));
-        let vars_mapping = (* create a sequence 'a -> 'a_0 for all variables *)
+	let vars_lhs =
+	  List.fold_left
+	    (fun acc x -> Var.Set.add (Var.mk (U.to_string x)) acc)
+	    Var.Set.empty
+	    args
+	in
+	let undecl = Var.Set.diff vars_rhs vars_lhs in
+        if not (Var.Set.is_empty undecl) then
+	  raise_loc_generic
+	    loc
+	    (Printf.sprintf "The definition of type %s contains an unbound type variable '%s"
+			    (Ident.to_string v)  (Var.ident (Var.Set.choose undecl)));
+
+	let vars_mapping = (* create a sequence 'a -> 'a_0 for all variables *)
           List.map (fun v -> let vv =  Var.mk (U.to_string v) in vv, Var.refresh vv) args
         in
         let sub_list = List.map (fun (v,vt) -> v, Types.var vt) vars_mapping in