[r2002-10-21 18:07:22 by cvscast] Empty log message

Original author: cvscast
Date: 2002-10-21 18:07:23+00:00

driver/cduce.ml

@@ -41,10 +41,13 @@ let rec print_exn ppf = function
         (Types.label_name l);
       Format.fprintf ppf "applied to an expression of type %a@\n"
         Types.Print.print_descr 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
-      msg
+        msg
   | Typer.Constraint (s,t,msg) ->
       Format.fprintf ppf "This expression should have type %a@\n" 
         Types.Print.print_descr t;
@@ -82,8 +85,9 @@ let () =
 	) [] p in
     Typer.register_global_types type_decls;
     List.iter phrase p
-  with  (Failure _) as e -> raise e
-       | exn -> print_exn ppf exn
+  with 
+    | (Failure _) as e -> raise e  (* To get the ocamlrun stack trace *)
+    | exn -> print_exn ppf exn
 	
 
 

typing/typer.ml

@@ -6,6 +6,7 @@ open Ast
 
 exception Pattern of string
 exception NonExhaustive of Types.descr
+exception MultipleLabel of Types.label
 exception Constraint of Types.descr * Types.descr * string
 exception ShouldHave of Types.descr * string
 exception WrongLabel of Types.descr * Types.label
@@ -334,9 +335,13 @@ let rec expr { loc = loc; descr = d } =
       | RecordLitt r -> 
 	  (* XXX TODO: check that no label appears twice *)
 	  let fv = ref Fv.empty in
+	  let labs = ref [] in
 	  let r = List.map 
 		    (fun (l,e) -> 
 		       let (fv2,e) = expr e in
+		       if (List.mem l !labs) then 
+			 raise_loc loc (MultipleLabel l);
+		       labs := l :: !labs;
 		       fv := Fv.union !fv fv2;
 		       (l,e)
 		    ) r in

typing/typer.mli

 exception Pattern of string
 exception NonExhaustive of Types.descr
+exception MultipleLabel of Types.label
 exception Constraint of Types.descr * Types.descr * string
 exception ShouldHave of Types.descr * string
 exception WrongLabel of Types.descr * Types.label