Suite du portage (nombreuses modifs)

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

1 files changed, 81 insertions, 63 deletions

diff --git a/debugger/printval.ml b/debugger/printval.ml
index 900e207ef0..0f3dcc7e26 100644
--- a/debugger/printval.ml
+++ b/debugger/printval.ml
@@ -124,6 +124,13 @@ exception Ellipsis
 let cautious f arg =
   try f arg with Ellipsis -> print_string "..."
 
+let check_depth depth obj ty =
+  if depth <= 0 then begin
+    let n = name_value obj ty in
+    print_char '$'; print_int n;
+    false
+  end else true
+
 let print_value max_depth obj ty env =
 
   let printer_steps = ref !max_printer_steps in
@@ -131,49 +138,54 @@ let print_value max_depth obj ty env =
   let rec print_val prio depth obj ty =
     decr printer_steps;
     if !printer_steps < 0 then raise Ellipsis;
-    if depth < 0 then begin
-      let n = name_value obj ty in
-      print_char '$'; print_int n
-    end else begin
-      try
-        find_printer env ty obj; ()
-      with Not_found ->
-        match (Ctype.repr ty).desc with
-          Tvar ->
-            print_string "<poly>"
-        | Tarrow(ty1, ty2) ->
-            print_string "<fun>"
-        | Ttuple(ty_list) ->
+    try
+      find_printer env ty obj; ()
+    with Not_found ->
+      match (Ctype.repr ty).desc with
+        Tvar ->
+          print_string "<poly>"
+      | Tarrow(ty1, ty2) ->
+          print_string "<fun>"
+      | Ttuple(ty_list) ->
+          if check_depth depth obj ty then begin
             if prio > 0
             then begin open_hovbox 1; print_string "(" end
             else open_hovbox 0;
             print_val_list 1 depth obj ty_list;
             if prio > 0 then print_string ")";
             close_box()
-        | Tconstr(path, [], _) when Path.same path Predef.path_exn ->
+          end
+      | Tconstr(path, [], _) when Path.same path Predef.path_exn ->
+          if check_depth depth obj ty then begin
             if prio > 1
             then begin open_hovbox 2; print_string "(" end
             else open_hovbox 1;
             print_exception obj;
             if prio > 1 then print_string ")";
             close_box()
-        | Tconstr(path, [ty_arg], _) when Path.same path Predef.path_list ->
+          end
+      | Tconstr(path, [ty_arg], _) when Path.same path Predef.path_list ->
+          if Debugcom.remote_value_is_int obj then
+            print_string "[]"
+          else if check_depth depth obj ty then begin
             let rec print_conses cons =
-              if not (Debugcom.remote_value_is_int cons) then begin
-                print_val 0 (depth - 1) (Debugcom.get_field cons 0) ty_arg;
-                let next_obj = Debugcom.get_field cons 1 in
-                if not (Debugcom.remote_value_is_int next_obj) then begin
-                  print_string ";"; print_space();
-                  print_conses next_obj
-                end
+              print_val 0 (depth - 1) (Debugcom.get_field cons 0) ty_arg;
+              let next_obj = Debugcom.get_field cons 1 in
+              if not (Debugcom.remote_value_is_int next_obj) then begin
+                print_string ";"; print_space();
+                print_conses next_obj
               end in
             open_hovbox 1;
             print_string "[";
             cautious print_conses obj;
             print_string "]";
             close_box()
-        | Tconstr(path, [ty_arg], _) when Path.same path Predef.path_array ->
-            let (tag, fields) = Debugcom.get_obj obj in
+          end
+      | Tconstr(path, [ty_arg], _) when Path.same path Predef.path_array ->
+          let (tag, fields) = Debugcom.get_obj obj in
+          if Array.length fields = 0 then
+            print_string "[||]"
+          else if check_depth depth obj ty then begin
             let rec print_items i =
               if i < Array.length fields then begin
                 if i > 0 then begin print_string ";"; print_space() end;
@@ -185,31 +197,33 @@ let print_value max_depth obj ty env =
             cautious print_items 0;
             print_string "|]";
             close_box()
-        | Tconstr(path, ty_list, _) ->
-            begin try
-              let decl = Env.find_type path env in
-              match decl with
-                {type_kind = Type_abstract; type_manifest = None} ->
-                  print_string "<abstr>"
-              | {type_kind = Type_abstract; type_manifest = Some body} ->
-                  print_val prio depth obj
-                            (Ctype.substitute decl.type_params ty_list body)
-              | {type_kind = Type_variant constr_list} ->
-                  let tag =
-                    if Debugcom.remote_value_is_int obj then
-                      Cstr_constant(Debugcom.int_value obj)
-                    else
-                      let (tag, sz) = Debugcom.get_header obj in
-                      Cstr_block tag in
-                  let (constr_name, constr_args) =
-                    find_constr tag 0 0 constr_list in
-                  let ty_args =
-                    List.map (Ctype.substitute decl.type_params ty_list)
-                        constr_args in
-                  begin match ty_args with
-                    [] ->
-                      print_string constr_name
-                  | [ty1] ->
+          end
+      | Tconstr(path, ty_list, _) ->
+          begin try
+            let decl = Env.find_type path env in
+            match decl with
+              {type_kind = Type_abstract; type_manifest = None} ->
+                print_string "<abstr>"
+            | {type_kind = Type_abstract; type_manifest = Some body} ->
+                print_val prio depth obj
+                          (Ctype.substitute decl.type_params ty_list body)
+            | {type_kind = Type_variant constr_list} ->
+                let tag =
+                  if Debugcom.remote_value_is_int obj then
+                    Cstr_constant(Debugcom.int_value obj)
+                  else
+                    let (tag, sz) = Debugcom.get_header obj in
+                    Cstr_block tag in
+                let (constr_name, constr_args) =
+                  find_constr tag 0 0 constr_list in
+                let ty_args =
+                  List.map (Ctype.substitute decl.type_params ty_list)
+                      constr_args in
+                begin match ty_args with
+                  [] ->
+                    print_string constr_name
+                | [ty1] ->
+                    if check_depth depth obj ty then begin
                       if prio > 1
                       then begin open_hovbox 2; print_string "(" end
                       else open_hovbox 1;
@@ -220,7 +234,9 @@ let print_value max_depth obj ty env =
                         ty1;
                       if prio > 1 then print_string ")";
                       close_box()
-                  | tyl ->
+                    end
+                | tyl ->
+                    if check_depth depth obj ty then begin
                       if prio > 1
                       then begin open_hovbox 2; print_string "(" end
                       else open_hovbox 1;
@@ -233,8 +249,10 @@ let print_value max_depth obj ty env =
                       close_box();
                       if prio > 1 then print_string ")";
                       close_box()
-                  end
-              | {type_kind = Type_record lbl_list} ->
+                    end
+                end
+            | {type_kind = Type_record lbl_list} ->
+                if check_depth depth obj ty then begin
                   let rec print_fields pos = function
                     [] -> ()
                   | (lbl_name, _, lbl_arg) :: remainder ->
@@ -256,17 +274,17 @@ let print_value max_depth obj ty env =
                   cautious (print_fields 0) lbl_list;
                   print_string "}";
                   close_box()
-            with
-              Not_found ->                (* raised by Env.find_type *)
-                print_string "<abstr>"
-            | Constr_not_found ->         (* raised by find_constr *)
-                print_string "<unknown constructor>"
-            end
-        | Tobject (_, _) ->
-            print_string "<obj>"
-        | Tfield(_, _, _) | Tnil | Tlink _ ->
-            fatal_error "Printval.print_value"
-      end
+                end
+          with
+            Not_found ->                (* raised by Env.find_type *)
+              print_string "<abstr>"
+          | Constr_not_found ->         (* raised by find_constr *)
+              print_string "<unknown constructor>"
+          end
+      | Tobject (_, _) ->
+          print_string "<obj>"
+      | Tfield(_, _, _) | Tnil | Tlink _ ->
+          fatal_error "Printval.print_value"
 
   and print_val_list prio depth obj ty_list =
     let rec print_list i = function