[r2002-10-21 18:58:02 by cvscast] Empty log message

Original author: cvscast
Date: 2002-10-21 18:58:02+00:00

driver/cduce.ml

@@ -21,6 +21,9 @@ let prog () =
   with
     | Stdpp.Exc_located (loc, e) -> raise (Location (loc, e))
 
+let print_norm ppf d = 
+  Types.Print.print_descr ppf (Types.normalize d)
+
 let rec print_exn ppf = function
   | Location ((i,j), exn) ->
       if source = "" then
@@ -40,26 +43,26 @@ let rec print_exn ppf = function
       Format.fprintf ppf "Wrong record selection: the label %s@\n" 
         (Types.label_name l);
       Format.fprintf ppf "applied to an expression of type %a@\n"
-        Types.Print.print_descr t
+        print_norm t
   | Typer.MultipleLabel l ->
       Format.fprintf ppf "Multiple occurences for the record label %s@\n"
         (Types.label_name l);
   | Typer.ShouldHave (t,msg) ->
       Format.fprintf ppf "This expression should have type %a@\n%s@\n" 
-        Types.Print.print_descr t
+        print_norm t
         msg
   | Typer.Constraint (s,t,msg) ->
       Format.fprintf ppf "This expression should have type %a@\n" 
-        Types.Print.print_descr t;
+        print_norm t;
       Format.fprintf ppf "but its infered type is: %a@\n" 
-        Types.Print.print_descr s;
+        print_norm s;
       Format.fprintf ppf "which is not a subtype, as shown by the value %a@\n" 
 	Types.Print.print_sample (Types.Sample.get (Types.diff s t));
       Format.fprintf ppf "%s@\n" msg
   | Typer.NonExhaustive t ->
       Format.fprintf ppf "This pattern matching is not exhaustive@\n";
       Format.fprintf ppf "Residual type: %a@\n"
-	Types.Print.print_descr t;
+	print_norm t;
       Format.fprintf ppf "Sample value: %a@\n" 
 	Types.Print.print_sample (Types.Sample.get t)
   | exn ->

types/types.ml

@@ -454,8 +454,13 @@ struct
 
 
   let restrict_label_present t l =
-    let aux = SortedMap.change l (fun (_,d) -> (false,d)) (false,any) in
-    List.map aux t
+    let restr = function 
+      | (true, d) -> if non_empty d then (false,d) else raise Exit 
+      | x -> x in
+    let aux accu r =  
+      try SortedMap.change l restr (false,any) r :: accu
+      with Exit -> accu in
+    List.fold_left aux [] t
 
   let restrict_label_absent t l =
     let restr = function (true, _) -> (true,empty) | _ -> raise Exit in
@@ -481,6 +486,9 @@ struct
     in
     List.fold_left aux empty t
 
+  let project d l =
+    project_field (get_record d.record) l
+
   type normal = 
       [ `Success
       | `Fail
@@ -519,31 +527,33 @@ struct
   let normal d =
     List.fold_left merge_record `Fail (get d)
 
-  let project d l =
-    let aux accu x =
-      match List.assoc l x with
-	| (false,t) -> cup accu t
-	| _ -> raise Not_found
-    in
-    List.fold_left aux empty (get_record d.record)
 
   let any = { empty with record = any.record }
   let is_empty d = d = []
 end
 
 
+module DescrHash = 
+  Hashtbl.Make(
+    struct 
+      type t = descr
+      let hash = hash_descr
+      let equal = equal_descr
+    end
+  )
+
 module MapDescr = Map.Make(struct type t = descr let compare = compare end)
 
-let memo_normalize = ref MapDescr.empty
+let memo_normalize = DescrHash.create 17
 
 let map_sort f l =
   SortedList.from_list (List.map f l)
 
 let rec rec_normalize d =
-  try MapDescr.find d !memo_normalize
+  try DescrHash.find memo_normalize d
   with Not_found ->
     let n = make () in
-    memo_normalize := MapDescr.add d n !memo_normalize;
+    DescrHash.add memo_normalize d n;
     let times = 
       map_sort
 	(fun (d1,d2) -> [(rec_normalize d1, rec_normalize d2)],[])
@@ -558,16 +568,7 @@ let rec rec_normalize d =
     n
 
 let normalize n =
-  internalize (rec_normalize (descr n))
-
-module DescrHash = 
-  Hashtbl.Make(
-    struct 
-      type t = descr
-      let hash = hash_descr
-      let equal = equal_descr
-    end
-  )
+  descr (internalize (rec_normalize n))
 
 module Print =
 struct

types/types.mli

@@ -151,7 +151,7 @@ module Atom : sig
   val has_atom : descr -> atom -> bool
 end
 
-val normalize : node -> node
+val normalize : descr -> descr
 
 (** Subtyping and sample values **)
 

typing/typer.ml

@@ -333,7 +333,10 @@ let rec expr { loc = loc; descr = d } =
 	  let (fv,e) = expr e in
 	  (fv,  Typed.Dot (e,l))
       | RecordLitt r -> 
-	  (* XXX TODO: check that no label appears twice *)
+	  (* Note: quadratic check for non duplication of labels.
+	     Should improve that to O(n log n) for dealing
+	     with huge number of attributes ?
+	  *)
 	  let fv = ref Fv.empty in
 	  let labs = ref [] in
 	  let r = List.map 
@@ -435,6 +438,35 @@ and type_check' loc env e constr precise = match e with
 	Types.times (Types.cons t1) (Types.cons t2)
       else
 	constr
+  | RecordLitt r ->
+      let rconstr = Types.Record.get constr in
+      if Types.Record.is_empty rconstr then
+	raise_loc loc (ShouldHave (constr,"but it is a record."));
+
+      let (rconstr,res) = 
+	List.fold_left 
+	  (fun (rconstr,res) (l,e) ->
+	     let rconstr = Types.Record.restrict_label_present rconstr l in
+	     let pi = Types.Record.project_field rconstr l in
+	     if Types.Record.is_empty rconstr then
+	       raise_loc loc 
+		 (ShouldHave (constr,(Printf.sprintf 
+					"Field %s is not allowed here."
+					(Types.label_name l)
+				     )
+			     ));
+	     let t = type_check env e pi true in
+	     let rconstr = Types.Record.restrict_field rconstr l t in
+	     
+	     let res = 
+	       if precise 
+	       then Types.cap res (Types.record l false (Types.cons t))
+	       else res in
+	     (rconstr,res)
+	  ) (rconstr, if precise then Types.Record.any else constr) r
+      in
+      res
+
   | _ -> 
       let t : Types.descr = compute_type' loc env e in
       check loc t constr "";
@@ -460,13 +492,6 @@ and compute_type' loc env = function
       let t = type_check env e Types.Record.any true in
          (try (Types.Record.project t l) 
           with Not_found -> raise_loc loc (WrongLabel(t,l)))
-  | RecordLitt r ->
-      List.fold_left 
-	(fun accu (l,e) ->
-	   let t = compute_type env e in
-	   let t = Types.record l false (Types.cons t) in
-	   Types.cap accu t
-	) Types.Record.any r
   | Op (op, el) ->
       let args = List.map (fun e -> (e.exp_loc, compute_type env e)) el in
       type_op loc op args