Merge olabl branch

git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@2651 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02

4 files changed, 38 insertions, 4 deletions

diff --git a/toplevel/genprintval.ml b/toplevel/genprintval.ml
index e2e73ae489..1fb94e064e 100644
--- a/toplevel/genprintval.ml
+++ b/toplevel/genprintval.ml
@@ -176,7 +176,7 @@ module Make(O : OBJ) = struct
           match (Ctype.repr ty).desc with
             Tvar ->
               print_string "<poly>"
-          | Tarrow(ty1, ty2) ->
+          | Tarrow(_, ty1, ty2) ->
               print_string "<fun>"
           | Ttuple(ty_list) ->
               if check_depth depth obj ty then begin
@@ -319,8 +319,33 @@ module Make(O : OBJ) = struct
               | Datarepr.Constr_not_found -> (* raised by find_constr_by_tag *)
                   print_string "<unknown constructor>"
               end
+	  | Tvariant row ->
+	      let row = Btype.row_repr row in
+	      if O.is_block obj then begin
+		let tag : int = O.obj (O.field obj 0) in
+		if prio > 1 then (open_box 2; print_char '(');
+		print_char '`';
+		List.iter
+		  (fun (l,f) -> if Btype.hash_variant l = tag then
+		    match Btype.row_field_repr f with
+		      Rpresent(Some ty) -> 
+			print_string l; print_space ();
+			cautious (print_val 2 (depth - 1) (O.field obj 1)) ty
+		    | _ -> ())
+		  row.row_fields;
+		if prio >1 then (print_char ')'; close_box ())
+	      end else begin
+		let tag : int = O.obj obj in
+		print_char '`';
+		List.iter
+		  (fun (l,_) ->
+		    if Btype.hash_variant l = tag then print_string l)
+		  row.row_fields
+	      end
           | Tobject (_, _) ->
               print_string "<obj>"
+	  | Tsubst ty ->
+	      print_val prio (depth - 1) obj ty
           | Tfield(_, _, _, _) | Tnil | Tlink _ ->
               fatal_error "Printval.print_value"
 
diff --git a/toplevel/topdirs.ml b/toplevel/topdirs.ml
index 06057e7f89..a9c08dcaad 100644
--- a/toplevel/topdirs.ml
+++ b/toplevel/topdirs.ml
@@ -120,7 +120,7 @@ let find_printer_type lid =
     Ctype.begin_def();
     let ty_arg = Ctype.newvar() in
     Ctype.unify !toplevel_env
-      (Ctype.newty (Tarrow(ty_arg, Ctype.instance Predef.type_unit)))
+      (Ctype.newty (Tarrow("", ty_arg, Ctype.instance Predef.type_unit)))
       (Ctype.instance desc.val_type);
     Ctype.end_def();
     Ctype.generalize ty_arg;
diff --git a/toplevel/topmain.ml b/toplevel/topmain.ml
index c7949087e7..acfa97a605 100644
--- a/toplevel/topmain.ml
+++ b/toplevel/topmain.ml
@@ -23,6 +23,7 @@ let main () =
   Arg.parse [
      "-I", Arg.String(fun dir -> include_dirs := dir :: !include_dirs),
            "<dir>  Add <dir> to the list of include directories";
+     "-modern", Arg.Clear classic, " Use strict label syntax";
      "-noassert", Arg.Set noassert, " Do not compile assertion checks";
      "-rectypes", Arg.Set recursive_types, " Allow arbitrary recursive types";
      "-unsafe", Arg.Set fast, " No bound checking on array and string access";
diff --git a/toplevel/trace.ml b/toplevel/trace.ml
index 92f6544e35..bfc657b529 100644
--- a/toplevel/trace.ml
+++ b/toplevel/trace.ml
@@ -55,11 +55,17 @@ let set_code_pointer cls ptr = Obj.set_field cls 0 ptr
 let invoke_traced_function codeptr env arg =
   Meta.invoke_traced_function codeptr env arg
 
+let print_label l =
+  if l <> "" then begin
+    print_string l;
+    print_char ':'
+  end
+
 (* If a function returns a functional value, wrap it into a trace code *)
 
 let rec instrument_result env name clos_typ =
   match (Ctype.repr(Ctype.expand_head env clos_typ)).desc with
-    Tarrow(t1, t2) ->
+    Tarrow(l, t1, t2) ->
       let starred_name =
         match name with
           Lident s -> Lident(s ^ "*")
@@ -71,6 +77,7 @@ let rec instrument_result env name clos_typ =
           open_box 2;
           Printtyp.longident starred_name;
           print_string " <--"; print_space();
+	  print_label l;
           print_value !toplevel_env arg t1;
           close_box(); print_newline();
           try
@@ -93,11 +100,12 @@ let rec instrument_result env name clos_typ =
 
 let instrument_closure env name clos_typ =
   match (Ctype.repr(Ctype.expand_head env clos_typ)).desc with
-    Tarrow(t1, t2) ->
+    Tarrow(l, t1, t2) ->
       let trace_res = instrument_result env name t2 in
       (fun actual_code closure arg ->
         open_box 2;
         Printtyp.longident name; print_string " <--"; print_space();
+	print_label l;
         print_value !toplevel_env arg t1;
         close_box(); print_newline();
         try