Revu les impressions du compilateur

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

10 files changed, 347 insertions, 423 deletions

diff --git a/toplevel/genprintval.ml b/toplevel/genprintval.ml
index 0e21ef131d..6921529e5a 100644
--- a/toplevel/genprintval.ml
+++ b/toplevel/genprintval.ml
@@ -15,7 +15,7 @@
 (* To print values *)
 
 open Misc
-open Formatmsg
+open Format
 open Longident
 open Path
 open Types
@@ -38,10 +38,10 @@ module type S =
     val install_printer : Path.t -> Types.type_expr -> (t -> unit) -> unit
     val remove_printer : Path.t -> unit
 
-    val print_exception : t -> unit
+    val print_exception : formatter -> t -> unit
     val print_value :
           int -> int -> (int -> t -> Types.type_expr -> bool) ->
-          Env.t -> t -> type_expr -> unit
+          Env.t -> t -> formatter -> type_expr -> unit
   end
 
 module Make(O : OBJ) = struct
@@ -53,85 +53,76 @@ module Make(O : OBJ) = struct
        Here, we do a feeble attempt to print
        integer, string and float arguments... *)
 
-    let print_exception_args obj start_offset =
+    let print_exception_args obj ppf start_offset =
       if O.size obj > start_offset then begin
-        open_box 1;
-        print_string "(";
+        fprintf ppf "@[<1>(";
         for i = start_offset to O.size obj - 1 do
-          if i > start_offset then begin print_string ","; print_space() end;
+          if i > start_offset then fprintf ppf ",@ ";
           let arg = O.field obj i in
           if not (O.is_block arg) then
-            print_int(O.obj arg : int)  (* Note: this could be a char! *)
-          else if O.tag arg = Obj.string_tag then begin
-            print_string "\"";
-            print_string (String.escaped (O.obj arg : string));
-            print_string "\""
-          end else if O.tag arg = Obj.double_tag then
-            print_float (O.obj arg : float)
+            fprintf ppf "%i" (O.obj arg : int) (* Note: this could be a char! *)
+          else if O.tag arg = Obj.string_tag then
+            fprintf ppf "\"%s\"" (String.escaped (O.obj arg : string))
+          else if O.tag arg = Obj.double_tag then
+            fprintf ppf "%f" (O.obj arg : float)
           else
-            print_string "_"
+            fprintf ppf "_"
         done;
-        print_string ")";
-        close_box()
+        fprintf ppf ")@]"
       end
 
-    let print_exception bucket =
+    let print_path = Printtyp.path
+
+    let print_exception ppf bucket =
       let name = (O.obj(O.field(O.field bucket 0) 0) : string) in
-      print_string name;
       if (name = "Match_failure" || name = "Assert_failure")
       && O.size bucket = 2
       && O.tag(O.field bucket 1) = 0
-      then print_exception_args (O.field bucket 1) 0
-      else print_exception_args bucket 1
+      then fprintf ppf "%s%a" name (print_exception_args (O.field bucket 1)) 0
+      else fprintf ppf "%s%a" name (print_exception_args bucket) 1
 
     (* The user-defined printers. Also used for some builtin types. *)
 
     let printers = ref ([
       Pident(Ident.create "print_int"), Predef.type_int,
-        (fun x -> print_int (O.obj x : int));
+        (fun ppf x -> fprintf ppf "%i" (O.obj x : int));
       Pident(Ident.create "print_float"), Predef.type_float,
-        (fun x -> print_float(O.obj x : float));
+        (fun ppf x -> fprintf ppf "%f" (O.obj x : float));
       Pident(Ident.create "print_char"), Predef.type_char,
-        (fun x -> print_string "'";
-                  print_string (Char.escaped (O.obj x : char));
-                  print_string "'");
+        (fun ppf x ->
+          fprintf ppf "'%s'" (Char.escaped (O.obj x : char)));
       Pident(Ident.create "print_string"), Predef.type_string,
-        (fun x -> print_string "\"";
-                  print_string (String.escaped (O.obj x : string));
-                  print_string "\"");
+        (fun ppf x ->
+          fprintf ppf "\"%s\"" (String.escaped (O.obj x : string)));
       Pident(Ident.create "print_int32"), Predef.type_int32,
-        (fun x -> print_string "<int32 ";
-                  print_string (Int32.to_string (O.obj x : int32));
-                  print_string ">");
+        (fun ppf x ->
+          fprintf ppf "<int32 %s>" (Int32.to_string (O.obj x : int32)));
       Pident(Ident.create "print_nativeint"), Predef.type_nativeint,
-        (fun x -> print_string "<nativeint ";
-                  print_string (Nativeint.to_string (O.obj x : nativeint));
-                  print_string ">");
+        (fun ppf x ->
+          fprintf ppf "<nativeint %s>"
+            (Nativeint.to_string (O.obj x : nativeint)));
       Pident(Ident.create "print_int64"), Predef.type_int64,
-        (fun x -> print_string "<int64 ";
-                  print_string (Int64.to_string (O.obj x : int64));
-                  print_string ">")
-    ] : (Path.t * type_expr * (O.t -> unit)) list)
+        (fun ppf x -> 
+          fprintf ppf "<int64 %s>" (Int64.to_string (O.obj x : int64)));
+    ] : (Path.t * type_expr * (Format.formatter -> O.t -> unit)) list)
 
     let install_printer path ty fn =
-      let print_val obj =
+      let print_val ppf obj =
         try fn obj with
-          exn ->
-            print_string "<printer ";
-            Printtyp.path path;
-            print_string " raised an exception>" in
+        | exn ->
+           fprintf ppf "<printer %a raised an exception>" Printtyp.path path in
       printers := (path, ty, print_val) :: !printers
 
     let remove_printer path =
       let rec remove = function
-        [] -> raise Not_found
+      | [] -> raise Not_found
       | (p, ty, fn as printer) :: rem ->
           if Path.same p path then rem else printer :: remove rem in
       printers := remove !printers
 
     let find_printer env ty =
       let rec find = function
-        [] -> raise Not_found
+      | [] -> raise Not_found
       | (name, sch, printer) :: remainder ->
           if Ctype.moregeneral env false sch ty
           then printer
@@ -142,20 +133,20 @@ module Make(O : OBJ) = struct
        it comes from. Attempt to omit the prefix if the type comes from
        a module that has been opened. *)
 
-    let print_qualified lookup_fun env ty_path name =
+    let print_qualified lookup_fun env ty_path ppf name =
       match ty_path with
-        Pident id ->
-          print_string name
+      | Pident id ->
+          fprintf ppf "%s" name
       | Pdot(p, s, pos) ->
           if try
                match (lookup_fun (Lident name) env).desc with
-                 Tconstr(ty_path', _, _) -> Path.same ty_path ty_path'
+               | Tconstr(ty_path', _, _) -> Path.same ty_path ty_path'
                | _ -> false
              with Not_found -> false
-          then print_string name
-          else (Printtyp.path p; print_string "."; print_string name)
+          then fprintf ppf "%s" name
+          else fprintf ppf "%a.%s" Printtyp.path p name
       | Papply(p1, p2) ->
-          Printtyp.path ty_path
+          Printtyp.path ppf ty_path
 
     let print_constr =
       print_qualified
@@ -175,83 +166,70 @@ module Make(O : OBJ) = struct
 
     let cautious f arg = try f arg with Ellipsis -> print_string "..."
 
-    let print_value max_steps max_depth check_depth env obj ty =
+    let print_value max_steps max_depth check_depth env obj ppf ty =
 
       let printer_steps = ref max_steps in
 
-      let rec print_val prio depth obj ty =
+      let rec print_val prio depth obj ppf ty =
         decr printer_steps;
         if !printer_steps < 0 or depth < 0 then raise Ellipsis;
         try
-          find_printer env ty obj; ()
+          find_printer env ty ppf obj
         with Not_found ->
           match (Ctype.repr ty).desc with
-            Tvar ->
-              print_string "<poly>"
+          | Tvar ->
+              fprintf ppf "<poly>"
           | Tarrow(_, ty1, ty2) ->
-              print_string "<fun>"
+              fprintf ppf "<fun>"
           | Ttuple(ty_list) ->
               if check_depth depth obj ty then begin
                 if prio > 0
-                then begin open_box 1; print_string "(" end
-                else open_box 0;
-                print_val_list 1 depth obj ty_list;
-                if prio > 0 then print_string ")";
-                close_box()
+                then
+                  fprintf ppf "@[<1>(%a)@]" (print_val_list 1 depth obj) ty_list
+                else fprintf ppf "@[%a@]" (print_val_list 1 depth obj) ty_list
               end
           | Tconstr(path, [], _) when Path.same path Predef.path_exn ->
               if check_depth depth obj ty then begin
                 if prio > 1
-                then begin open_box 2; print_string "(" end
-                else open_box 1;
-                print_exception obj;
-                if prio > 1 then print_string ")";
-                close_box()
+                then fprintf ppf "@[<2>(%a)@]" print_exception obj
+                else fprintf ppf "@[<1>%a@]" print_exception obj
               end
           | Tconstr(path, [ty_arg], _) when Path.same path Predef.path_list ->
               if O.is_block obj then begin
                 if check_depth depth obj ty then begin
-                  let rec print_conses cons =
-                    print_val 0 (depth - 1) (O.field cons 0) ty_arg;
+                  let rec print_conses ppf cons =
+                    print_val 0 (depth - 1) (O.field cons 0) ppf ty_arg;
                     let next_obj = O.field cons 1 in
-                    if O.is_block next_obj then begin
-                      print_string ";"; print_space();
-                      print_conses next_obj
-                    end
+                    if O.is_block next_obj then
+                      fprintf ppf ";@ %a" print_conses next_obj
                   in
-                  open_box 1;
-                  print_string "[";
-                  cautious print_conses obj;
-                  print_string "]";
-                  close_box()
+                  fprintf ppf "@[<1>[%a]@]"
+                  (fun ppf obj -> cautious (print_conses ppf) obj) obj
                 end
               end else
-                print_string "[]"
+                fprintf ppf "[]"
           | Tconstr(path, [ty_arg], _) when Path.same path Predef.path_array ->
               let length = O.size obj in
               if length = 0 then
-                print_string "[||]"
+                fprintf ppf "[||]"
               else if check_depth depth obj ty then begin
-                let rec print_items i =
+                let rec print_items ppf i =
                   if i < length then begin
-                    if i > 0 then begin print_string ";"; print_space() end;
-                    print_val 0 (depth - 1) (O.field obj i) ty_arg;
-                    print_items (i + 1)
+                    if i > 0 then fprintf ppf ";@ ";
+                    print_val 0 (depth - 1) (O.field obj i) ppf ty_arg;
+                    print_items ppf (i + 1)
                   end in
-                open_box 2;
-                print_string "[|";
-                cautious print_items 0;
-                print_string "|]";
-                close_box()
+                fprintf ppf "@[<2>[|%a|]@]"
+                        (fun ppf i -> cautious (print_items ppf) i) 0;
               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 = None} ->
+                    fprintf ppf "<abstr>"
                 | {type_kind = Type_abstract; type_manifest = Some body} ->
-                    print_val prio depth obj
+                    print_val prio depth obj ppf
                       (try Ctype.apply env decl.type_params body ty_list with
                          Ctype.Cannot_apply -> abstract_type)
                 | {type_kind = Type_variant constr_list} ->
@@ -268,108 +246,93 @@ module Make(O : OBJ) = struct
                              Ctype.Cannot_apply -> abstract_type)
                         constr_args in
                     begin match ty_args with
-                      [] ->
-                        print_constr env path constr_name
+                    | [] ->
+                        print_constr env path ppf constr_name
                     | [ty1] ->
-                        if check_depth depth obj ty then begin
-                          if prio > 1
-                          then begin open_box 2; print_string "(" end
-                          else open_box 1;
-                          print_constr env path constr_name;
-                          print_space();
-                          cautious (print_val 2 (depth - 1)
-                                      (O.field obj 0)) ty1;
-                          if prio > 1 then print_string ")";
-                          close_box()
-                        end
+                        if check_depth depth obj ty then
+                          (if prio > 1
+                          then fprintf ppf "@[<2>(%a@ %a)@]"
+                          else fprintf ppf "@[<1>%a@ %a@]")
+                          (print_constr env path) constr_name
+                          (fun ppf ty ->
+                             cautious
+                              (print_val 2 (depth - 1) (O.field obj 0) ppf) ty)
+                          ty1;
                     | tyl ->
-                        if check_depth depth obj ty then begin
-                          if prio > 1
-                          then begin open_box 2; print_string "(" end
-                          else open_box 1;
-                          print_constr env path constr_name;
-                          print_space();
-                          open_box 1;
-                          print_string "(";
-                          print_val_list 1 depth obj tyl;
-                          print_string ")";
-                          close_box();
-                          if prio > 1 then print_string ")";
-                          close_box()
-                        end
+                        if check_depth depth obj ty then
+                          (if prio > 1
+                          then fprintf ppf "@[<2>(%a@ @[<1>(%a)@])@]"
+                          else fprintf ppf "@[<1>%a@ @[<1>(%a)@]@]")
+                          (print_constr env path) constr_name
+                          (print_val_list 1 depth obj) tyl;
                     end
                 | {type_kind = Type_record lbl_list} ->
                     if check_depth depth obj ty then begin
-                      let rec print_fields pos = function
-                        [] -> ()
+                      let rec print_fields pos ppf = function
+                      | [] -> ()
                       | (lbl_name, _, lbl_arg) :: remainder ->
-                          if pos > 0 then begin
-                            print_string ";"; print_space()
-                          end;
-                          open_box 1;
-                          print_label env path lbl_name;
-                          print_string "="; print_cut();
                           let ty_arg =
                             try
                               Ctype.apply env decl.type_params lbl_arg ty_list
                             with
-                              Ctype.Cannot_apply -> abstract_type
-                          in
-                          cautious (print_val 0 (depth - 1)
-                                      (O.field obj pos)) ty_arg;
-                          close_box();
-                          print_fields (pos + 1) remainder in
-                      open_box 1;
-                      print_string "{";
-                      cautious (print_fields 0) lbl_list;
-                      print_string "}";
-                      close_box()
+                              Ctype.Cannot_apply -> abstract_type in
+                          if pos > 0 then fprintf ppf ";@ ";
+                          fprintf ppf "@[<1>%a=@,%a@]"
+                          (print_label env path) lbl_name
+                          (fun ppf t ->
+                             cautious (print_val 0 (depth - 1)
+                                      (O.field obj pos) ppf) t) ty_arg;
+                          (print_fields (pos + 1)) ppf remainder in
+
+                      fprintf ppf "@[<1>{%a}@]"
+                      (fun ppf l -> cautious (print_fields 0 ppf) l) lbl_list;
                     end
               with
                 Not_found ->                (* raised by Env.find_type *)
-                  print_string "<abstr>"
+                  fprintf ppf "<abstr>"
               | Datarepr.Constr_not_found -> (* raised by find_constr_by_tag *)
-                  print_string "<unknown constructor>"
+                  fprintf ppf "<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
-                    | _ -> ())
+                (if prio > 1
+                 then fprintf ppf "@[<2>(`%a)@]"
+                 else fprintf ppf "`%a")
+                (fun ppf ->
+                  List.iter
+                   (fun (l, f) -> if Btype.hash_variant l = tag then
+                     match Btype.row_field_repr f with
+                     | Rpresent(Some ty) ->
+                        fprintf ppf "%s@ " l;
+                        cautious (print_val 2 (depth - 1) (O.field obj 1) ppf)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)
+                    if Btype.hash_variant l = tag then fprintf ppf "%s" l)
                   row.row_fields
               end
           | Tobject (_, _) ->
-              print_string "<obj>"
+              fprintf ppf "<obj>"
           | Tsubst ty ->
-              print_val prio (depth - 1) obj ty
+              print_val prio (depth - 1) obj ppf ty
           | Tfield(_, _, _, _) | Tnil | Tlink _ ->
               fatal_error "Printval.print_value"
 
-      and print_val_list prio depth obj ty_list =
+      and print_val_list prio depth obj ppf ty_list =
         let rec print_list i = function
-          [] -> ()
-        | ty :: ty_list ->
-            if i > 0 then begin print_string ","; print_space() end;
-            print_val prio (depth - 1) (O.field obj i) ty;
-            print_list (i + 1) ty_list in
+          |  [] -> ()
+          | ty :: ty_list ->
+              if i > 0 then fprintf ppf ",@ ";
+              print_val prio (depth - 1) (O.field obj i) ppf ty;
+              print_list (i + 1) ty_list in
       cautious (print_list 0) ty_list
 
-    in cautious (print_val 0 max_depth obj) ty
+    in cautious (print_val 0 max_depth obj ppf) ty
 
 end
diff --git a/toplevel/genprintval.mli b/toplevel/genprintval.mli
index f4732341c5..832d40cbc7 100644
--- a/toplevel/genprintval.mli
+++ b/toplevel/genprintval.mli
@@ -15,6 +15,7 @@
 (* Printing of values *)
 
 open Types
+open Format
 
 module type OBJ =
   sig
@@ -34,10 +35,10 @@ module type S =
     val install_printer : Path.t -> Types.type_expr -> (t -> unit) -> unit
     val remove_printer : Path.t -> unit
 
-    val print_exception : t -> unit
+    val print_exception : formatter -> t -> unit
     val print_value :
           int -> int -> (int -> t -> Types.type_expr -> bool) ->
-          Env.t -> t -> type_expr -> unit
+          Env.t -> t -> formatter -> type_expr -> unit
   end
 
 module Make(O : OBJ) : (S with type t = O.t)
diff --git a/toplevel/printval.mli b/toplevel/printval.mli
index 385fbcd492..c8302df0a9 100644
--- a/toplevel/printval.mli
+++ b/toplevel/printval.mli
@@ -15,9 +15,10 @@
 (* Printing of values *)
 
 open Types
+open Format
 
-val print_exception: Obj.t -> unit
-val print_value: Env.t -> Obj.t -> type_expr -> unit
+val print_exception: formatter -> Obj.t -> unit
+val print_value: Env.t -> Obj.t -> formatter -> type_expr -> unit
 
 val install_printer : Path.t -> Types.type_expr -> (Obj.t -> unit) -> unit
 val remove_printer : Path.t -> unit
diff --git a/toplevel/topdirs.ml b/toplevel/topdirs.ml
index 68140e59a3..dd89eca9bb 100644
--- a/toplevel/topdirs.ml
+++ b/toplevel/topdirs.ml
@@ -14,7 +14,7 @@
 
 (* Toplevel directives *)
 
-open Formatmsg
+open Format
 open Misc
 open Longident
 open Path
@@ -24,16 +24,19 @@ open Printval
 open Trace
 open Toploop
 
+(* The standard error formatter *)
+let std_err = err_formatter
+
 (* Return the value referred to by a path *)
 
 let rec eval_path = function
-    Pident id -> Symtable.get_global_value id
+  | Pident id -> Symtable.get_global_value id
   | Pdot(p, s, pos) -> Obj.field (eval_path p) pos
   | Papply(p1, p2) -> fatal_error "Topdirs.eval_path"
 
 (* To quit *)
 
-let dir_quit () = exit 0; ()
+let dir_quit () = exit 0
 
 let _ = Hashtbl.add directive_table "quit" (Directive_none dir_quit)
 
@@ -47,8 +50,7 @@ let _ = Hashtbl.add directive_table "directory" (Directive_string dir_directory)
 
 (* To change the current directory *)
 
-let dir_cd s =
-  Sys.chdir s
+let dir_cd s = Sys.chdir s
 
 let _ = Hashtbl.add directive_table "cd" (Directive_string dir_cd)
 
@@ -56,7 +58,7 @@ let _ = Hashtbl.add directive_table "cd" (Directive_string dir_cd)
 
 exception Load_failed
 
-let load_compunit ic filename compunit =
+let load_compunit ic filename ppf compunit =
   Bytelink.check_consistency filename compunit;
   seek_in ic compunit.cu_pos;
   let code_size = compunit.cu_codesize + 8 in
@@ -72,11 +74,11 @@ let load_compunit ic filename compunit =
     ignore((Meta.reify_bytecode code code_size) ())
   with exn ->
     Symtable.restore_state initial_symtable;
-    print_exception_outcome exn;
+    print_exception_outcome ppf exn;
     raise Load_failed
   end
 
-let dir_load name =
+let dir_load ppf name =
   try
     let filename = find_in_path !Config.load_path name in
     let ic = open_in_bin filename in
@@ -86,34 +88,30 @@ let dir_load name =
       if buffer = Config.cmo_magic_number then begin
         let compunit_pos = input_binary_int ic in  (* Go to descriptor *)
         seek_in ic compunit_pos;
-        load_compunit ic filename (input_value ic : compilation_unit)
+        load_compunit ic filename ppf (input_value ic : compilation_unit)
       end else
       if buffer = Config.cma_magic_number then begin
         let toc_pos = input_binary_int ic in  (* Go to table of contents *)
         seek_in ic toc_pos;
-        List.iter (load_compunit ic filename)
+        List.iter (load_compunit ic filename ppf)
                   (input_value ic : compilation_unit list)
-      end else begin
-        print_string "File "; print_string name;
-        print_string " is not a bytecode object file."; print_newline()
-      end
+      end else fprintf ppf "File %s is not a bytecode object file.@." name
     with Load_failed -> ()
     end;
     close_in ic
-  with Not_found ->
-         print_string "Cannot find file "; print_string name; print_newline()
+  with Not_found -> fprintf ppf "Cannot find file %s.@." name
 
-let _ = Hashtbl.add directive_table "load" (Directive_string dir_load)
+let _ = Hashtbl.add directive_table "load" (Directive_string (dir_load std_err))
 
 (* Load commands from a file *)
 
-let dir_use name = ignore(Toploop.use_file name)
+let dir_use ppf name = ignore(Toploop.use_file ppf name)
 
-let _ = Hashtbl.add directive_table "use" (Directive_string dir_use)
+let _ = Hashtbl.add directive_table "use" (Directive_string (dir_use std_err))
 
 (* Install, remove a printer *)
 
-let find_printer_type lid =
+let find_printer_type ppf lid =
   try
     let (path, desc) = Env.lookup_value lid !toplevel_env in
     Ctype.init_def(Ident.current_time());
@@ -126,38 +124,35 @@ let find_printer_type lid =
     Ctype.generalize ty_arg;
     (ty_arg, path)
   with 
-    Not_found ->
-      print_string "Unbound value "; Printtyp.longident lid;
-      print_newline(); raise Exit
+  | Not_found ->
+      fprintf ppf "Unbound value %a.@." Printtyp.longident lid;
+      raise Exit
   | Ctype.Unify _ ->
+      fprintf ppf "%a has a wrong type for a printing function.@."
       Printtyp.longident lid;
-      print_string " has the wrong type for a printing function";
-      print_newline(); raise Exit
+      raise Exit
     
-let dir_install_printer lid =
+let dir_install_printer ppf lid =
   try
-    let (ty_arg, path) = find_printer_type lid in
+    let (ty_arg, path) = find_printer_type ppf lid in
     let v = (Obj.obj (eval_path path) : 'a -> unit) in
     Printval.install_printer path ty_arg (fun repr -> v (Obj.obj repr))
-  with Exit ->
-    ()
+  with Exit -> ()
 
-let dir_remove_printer lid =
+let dir_remove_printer ppf lid =
   try
-    let (ty_arg, path) = find_printer_type lid in
+    let (ty_arg, path) = find_printer_type ppf lid in
     begin try
       Printval.remove_printer path
     with Not_found ->
-      print_string "No printer named "; Printtyp.longident lid;
-      print_newline()
+      fprintf ppf "No printer named %a.@." Printtyp.longident lid
     end
-  with Exit ->
-    ()
+  with Exit -> ()
 
 let _ = Hashtbl.add directive_table "install_printer"
-             (Directive_ident dir_install_printer)
+             (Directive_ident (dir_install_printer std_err))
 let _ = Hashtbl.add directive_table "remove_printer"
-             (Directive_ident dir_remove_printer)
+             (Directive_ident (dir_remove_printer std_err))
 
 (* The trace *)
 
@@ -167,26 +162,24 @@ let tracing_function_ptr =
   get_code_pointer
     (Obj.repr (fun arg -> Trace.print_trace (current_environment()) arg))
 
-let dir_trace lid =
+let dir_trace ppf lid =
   try
     let (path, desc) = Env.lookup_value lid !toplevel_env in
     (* Check if this is a primitive *)
     match desc.val_kind with
-      Val_prim p ->
-        Printtyp.longident lid;
-        print_string " is an external function and cannot be traced.";
-        print_newline()
+    | Val_prim p ->
+        fprintf ppf "%a is an external function and cannot be traced.@."
+        Printtyp.longident lid
     | _ ->
         let clos = eval_path path in
         (* Nothing to do if it's not a closure *)
         if Obj.is_block clos &&
            (Obj.tag clos = 250 || Obj.tag clos = 249) then begin
         match is_traced clos with
-          Some opath ->
-            Printtyp.path path;
-            print_string " is already traced (under the name ";
-            Printtyp.path opath; print_string ")";
-            print_newline()
+        | Some opath ->
+            fprintf ppf "%a is already traced (under the name %a).@."
+            Printtyp.path path
+            Printtyp.path opath
         | None ->
             (* Instrument the old closure *)
             traced_functions :=
@@ -194,69 +187,62 @@ let dir_trace lid =
                 closure = clos;
                 actual_code = get_code_pointer clos;
                 instrumented_fun =
-                  instrument_closure !toplevel_env lid desc.val_type }
+                  instrument_closure !toplevel_env lid ppf desc.val_type }
               :: !traced_functions;
             (* Redirect the code field of the closure to point
                to the instrumentation function *)
             set_code_pointer clos tracing_function_ptr;
-            Printtyp.longident lid; print_string " is now traced.";
-            print_newline()
-        end else begin
-          Printtyp.longident lid; print_string " is not a function.";
-          print_newline()
-        end      
-  with Not_found ->
-    print_string "Unbound value "; Printtyp.longident lid;
-    print_newline()
-
-let dir_untrace lid =
+            fprintf ppf "%a is now traced.@." Printtyp.longident lid
+        end else fprintf ppf "%a is not a function.@." Printtyp.longident lid
+  with
+  | Not_found -> fprintf ppf "Unbound value %a.@." Printtyp.longident lid
+
+let dir_untrace ppf lid =
   try
     let (path, desc) = Env.lookup_value lid !toplevel_env in
     let rec remove = function
-      [] ->
-        Printtyp.longident lid; print_string " was not traced.";
-        print_newline();
+    | [] ->
+        fprintf ppf "%a was not traced.@." Printtyp.longident lid;
         []
     | f :: rem ->
         if Path.same f.path path then begin
           set_code_pointer (eval_path path) f.actual_code;
-          Printtyp.longident lid; print_string " is no longer traced.";
-          print_newline();
+          fprintf ppf "%a is no longer traced.@." Printtyp.longident lid;
           rem
         end else f :: remove rem in
     traced_functions := remove !traced_functions
-  with Not_found ->
-    print_string "Unbound value "; Printtyp.longident lid;
-    print_newline()
+  with
+  | Not_found -> fprintf ppf "Unbound value %a.@." Printtyp.longident lid
 
-let dir_untrace_all () =
+let dir_untrace_all ppf () =
   List.iter
     (fun f ->
       set_code_pointer (eval_path f.path) f.actual_code;
-      Printtyp.path f.path; print_string " is no longer traced.";
-      print_newline())
+      fprintf ppf "%a is no longer traced.@." Printtyp.path f.path)
     !traced_functions;
   traced_functions := []
 
-let _ = Hashtbl.add directive_table "trace" (Directive_ident dir_trace)
-let _ = Hashtbl.add directive_table "untrace" (Directive_ident dir_untrace)
-let _ = Hashtbl.add directive_table "untrace_all" (Directive_none dir_untrace_all)
+let parse_warnings ppf s =
+  try Warnings.parse_options s
+  with Arg.Bad err -> fprintf ppf "%s.@." err
+
+let _ =
+  Hashtbl.add directive_table "trace" (Directive_ident (dir_trace std_err));
+  Hashtbl.add directive_table "untrace" (Directive_ident (dir_untrace std_err));
+  Hashtbl.add directive_table
+    "untrace_all" (Directive_none (dir_untrace_all std_err));
 
 (* Control the printing of values *)
 
-let _ = Hashtbl.add directive_table "print_depth"
-             (Directive_int(fun n -> max_printer_depth := n))
-let _ = Hashtbl.add directive_table "print_length"
-             (Directive_int(fun n -> max_printer_steps := n))
+  Hashtbl.add directive_table "print_depth"
+             (Directive_int(fun n -> max_printer_depth := n));
+  Hashtbl.add directive_table "print_length"
+             (Directive_int(fun n -> max_printer_steps := n));
 
 (* Set various compiler flags *)
 
-let _ = Hashtbl.add directive_table "modern"
-             (Directive_bool(fun b -> Clflags.classic := not b))
-
-let parse_warnings s =
-  try Warnings.parse_options s
-  with Arg.Bad err -> printf "%s." err
+  Hashtbl.add directive_table "modern"
+             (Directive_bool(fun b -> Clflags.classic := not b));
 
-let _ = Hashtbl.add directive_table "warnings"
-             (Directive_string parse_warnings)
+  Hashtbl.add directive_table "warnings"
+             (Directive_string (parse_warnings std_err))
diff --git a/toplevel/topdirs.mli b/toplevel/topdirs.mli
index 11aafc814e..1af7209bf8 100644
--- a/toplevel/topdirs.mli
+++ b/toplevel/topdirs.mli
@@ -14,14 +14,16 @@
 
 (* The toplevel directives. *)
 
+open Format
+
 val dir_quit : unit -> unit
 val dir_directory : string -> unit
 val dir_cd : string -> unit
-val dir_load : string -> unit
-val dir_use : string -> unit
-val dir_install_printer : Longident.t -> unit
-val dir_remove_printer : Longident.t -> unit
-val dir_trace : Longident.t -> unit
-val dir_untrace : Longident.t -> unit
-val dir_untrace_all : unit -> unit
+val dir_load : formatter -> string -> unit
+val dir_use : formatter -> string -> unit
+val dir_install_printer : formatter -> Longident.t -> unit
+val dir_remove_printer : formatter -> Longident.t -> unit
+val dir_trace : formatter -> Longident.t -> unit
+val dir_untrace : formatter -> Longident.t -> unit
+val dir_untrace_all : formatter -> unit -> unit
 
diff --git a/toplevel/toploop.ml b/toplevel/toploop.ml
index fca2428be1..83fa9ca23a 100644
--- a/toplevel/toploop.ml
+++ b/toplevel/toploop.ml
@@ -15,7 +15,7 @@
 (* The interactive toplevel loop *)
 
 open Lexing
-open Formatmsg
+open Format
 open Config
 open Misc
 open Parsetree
@@ -24,11 +24,11 @@ open Typedtree
 open Printval
 
 type directive_fun =
-    Directive_none of (unit -> unit)
-  | Directive_string of (string -> unit)
-  | Directive_int of (int -> unit)
-  | Directive_ident of (Longident.t -> unit)
-  | Directive_bool of (bool -> unit)
+   | Directive_none of (unit -> unit)
+   | Directive_string of (string -> unit)
+   | Directive_int of (int -> unit)
+   | Directive_ident of (Longident.t -> unit)
+   | Directive_bool of (bool -> unit)
 
 (* Hooks for parsing functions *)
 
@@ -42,20 +42,15 @@ let input_name = Location.input_name
 
 type evaluation_outcome = Result of Obj.t | Exception of exn
 
-let load_lambda lam =
-  if !Clflags.dump_rawlambda then begin
-    Printlambda.lambda lam; print_newline()
-  end;
+let load_lambda ppf lam =
+  if !Clflags.dump_rawlambda then fprintf ppf "%a@." Printlambda.lambda lam;
   let slam = Simplif.simplify_lambda lam in
-  if !Clflags.dump_lambda then begin
-    Printlambda.lambda slam; print_newline()
-  end;
+  if !Clflags.dump_lambda then fprintf ppf "%a@." Printlambda.lambda slam;
   let (init_code, fun_code) = Bytegen.compile_phrase slam in
-  if !Clflags.dump_instr then begin
-    Printinstr.instrlist init_code;
+  if !Clflags.dump_instr then
+    fprintf ppf "%a%a@."
+    Printinstr.instrlist init_code
     Printinstr.instrlist fun_code;
-    print_newline()
-  end;
   let (code, code_size, reloc) = Emitcode.to_memory init_code fun_code in
   let can_free = (fun_code = []) in
   let initial_symtable = Symtable.current_state() in
@@ -72,57 +67,59 @@ let load_lambda lam =
 
 (* Print the outcome of an evaluation *)
 
-let rec print_items env = function
-    Tsig_value(id, decl)::rem ->
-      open_box 2;
-      Printtyp.value_description id decl;
+let rec print_items env ppf = function
+  | Tsig_value(id, decl)::rem ->
+      printf "@[<2>%a"
+      (Printtyp.value_description id) decl;
       begin match decl.val_kind with
-        Val_prim _ -> ()
+      | Val_prim _ -> ()
       | _ ->
-          print_string " ="; print_space();
-          print_value env (Symtable.get_global_value id) decl.val_type
+          fprintf ppf " =@ %a"
+          (fun ppf t ->
+            (print_value env (Symtable.get_global_value id)) ppf t)
+          decl.val_type
       end;
-      close_box();
-      print_space (); print_items env rem
+      fprintf ppf "@]@ %a" (print_items env) rem
   | Tsig_type(id, decl)::rem ->
-      Printtyp.type_declaration id decl;
-      print_space (); print_items env rem
+      fprintf ppf "@[%a@ %a@]"
+      (Printtyp.type_declaration id) decl
+      (print_items env) rem
   | Tsig_exception(id, decl)::rem ->
-      Printtyp.exception_declaration id decl;
-      print_space (); print_items env rem
+      fprintf ppf "@[%a@ %a@]"
+      (Printtyp.exception_declaration id) decl
+      (print_items env) rem
   | Tsig_module(id, mty)::rem ->
-      open_box 2; print_string "module "; Printtyp.ident id;
-      print_string " :"; print_space(); Printtyp.modtype mty; close_box();
-      print_space (); print_items env rem
+      fprintf ppf "@[<2>module %a :@ %a@]@ %a"
+      Printtyp.ident id
+      Printtyp.modtype mty
+      (print_items env) rem
   | Tsig_modtype(id, decl)::rem ->
-      Printtyp.modtype_declaration id decl;
-      print_space (); print_items env rem
+      fprintf ppf "@[%a@ %a@]" 
+      (Printtyp.modtype_declaration id) decl
+      (print_items env) rem
   | Tsig_class(id, decl)::cltydecl::tydecl1::tydecl2::rem ->
-      Printtyp.class_declaration id decl;
-      print_space (); print_items env rem
+      fprintf ppf "@[%a@ %a@]"
+      (Printtyp.class_declaration id) decl
+      (print_items env) rem
   | Tsig_cltype(id, decl)::tydecl1::tydecl2::rem ->
-      Printtyp.cltype_declaration id decl;
-      print_space (); print_items env rem
-  | _ ->
-      ()
+      fprintf ppf "@[%a@ %a@]" 
+      (Printtyp.cltype_declaration id) decl
+      (print_items env) rem
+  | _ -> ()
 
 (* Print an exception produced by an evaluation *)
 
-let print_exception_outcome = function
-    Sys.Break ->
-      print_string "Interrupted."; print_newline()
+let print_exception_outcome ppf = function
+  | Sys.Break ->
+      fprintf ppf "Interrupted.@."
   | Out_of_memory ->
       Gc.full_major();
-      print_string "Out of memory during evaluation.";
-      print_newline()
+      fprintf ppf "Out of memory during evaluation.@."
   | Stack_overflow ->
-      print_string "Stack overflow during evaluation (looping recursion?).";
-      print_newline();
+      fprintf ppf "Stack overflow during evaluation (looping recursion?).@."
   | exn ->
-      open_box 0;
-      print_string "Uncaught exception: ";
-      print_exception (Obj.repr exn);
-      print_newline()
+      fprintf ppf "@[Uncaught exception: %a.@."
+      print_exception (Obj.repr exn)
 
 (* The table of toplevel directives. 
    Filled by functions from module topdirs. *)
@@ -133,51 +130,43 @@ let directive_table = (Hashtbl.create 13 : (string, directive_fun) Hashtbl.t)
 
 let toplevel_env = ref Env.empty
 
-let execute_phrase print_outcome phr =
+let execute_phrase print_outcome ppf phr =
   match phr with
-    Ptop_def sstr ->
+  | Ptop_def sstr ->
       let (str, sg, newenv) = Typemod.type_structure !toplevel_env sstr in
       let lam = Translmod.transl_toplevel_definition str in
-      let res = load_lambda lam in
+      let res = load_lambda ppf lam in
       begin match res with
-        Result v ->
+      | Result v ->
           if print_outcome then begin
             match str with
-              [Tstr_eval exp] ->
-                open_box 0;
-                print_string "- : ";
-                Printtyp.type_scheme exp.exp_type;
-                print_space(); print_string "="; print_space();
-                print_value newenv v exp.exp_type;
-                close_box();
-                print_newline()
+            | [Tstr_eval exp] ->
+                fprintf ppf "@[- : %a@ =@ %a@]@."
+                Printtyp.type_scheme exp.exp_type
+                (print_value newenv v) exp.exp_type
             | _ ->
-                open_vbox 0;
-                print_items newenv sg;
-                close_box();
-                print_flush()
+                fprintf ppf "@[<v>%a@]@\n"
+                (print_items newenv) sg
           end;
           toplevel_env := newenv;
           true
       | Exception exn ->
-          print_exception_outcome exn;
+          print_exception_outcome ppf exn;
           false
       end
   | Ptop_dir(dir_name, dir_arg) ->
       try
         match (Hashtbl.find directive_table dir_name, dir_arg) with
-          (Directive_none f, Pdir_none) -> f (); true
+        | (Directive_none f, Pdir_none) -> f (); true
         | (Directive_string f, Pdir_string s) -> f s; true
         | (Directive_int f, Pdir_int n) -> f n; true
         | (Directive_ident f, Pdir_ident lid) -> f lid; true
         | (Directive_bool f, Pdir_bool b) -> f b; true
         | (_, _) ->
-            print_string "Wrong type of argument for directive `";
-            print_string dir_name; print_string "'"; print_newline();
+            fprintf ppf "Wrong type of argument for directive `%s'.@." dir_name;
             false
       with Not_found ->
-        print_string "Unknown directive `"; print_string dir_name;
-        print_string "'"; print_newline();
+        fprintf ppf "Unknown directive `%s'.@." dir_name;
         false
 
 (* Temporary assignment to a reference *)
@@ -197,7 +186,7 @@ let protect r newval body =
 
 let use_print_results = ref true
 
-let use_file name =
+let use_file ppf name =
   try
     let filename = find_in_path !Config.load_path name in
     let ic = open_in_bin filename in
@@ -212,21 +201,17 @@ let use_file name =
         try
           List.iter
             (fun ph ->
-              if !Clflags.dump_parsetree then Printast.top_phrase ph;
-              if execute_phrase !use_print_results ph then () else raise Exit)
+              if !Clflags.dump_parsetree then Printast.top_phrase ppf ph;
+              if not (execute_phrase !use_print_results ppf ph) then raise Exit)
             (!parse_use_file lb);
           true
         with
-          Exit -> false
-        | Sys.Break ->
-            print_string "Interrupted."; print_newline(); false
-        | x ->
-            Errors.report_error x; false) in
+        | Exit -> false
+        | Sys.Break -> fprintf ppf "Interrupted.@."; false
+        | x -> Errors.report_error ppf x; false) in
     close_in ic;
     success
-  with Not_found ->
-    print_string "Cannot find file "; print_string name; print_newline();
-    false
+  with Not_found -> fprintf ppf "Cannot find file %s.@." name; false
 
 let use_silently name =
   protect use_print_results false (fun () -> use_file name)
@@ -253,9 +238,7 @@ let refill_lexbuf buffer len =
     with
     | End_of_file ->
         Location.echo_eof ();
-        if !i > 0
-        then (got_eof := true; !i)
-        else 0
+        if !i > 0 then (got_eof := true; !i) else 0
     | Exit -> !i
   end
 
@@ -276,17 +259,15 @@ let _ =
   Clflags.thread_safe := true;
   Compile.init_path()
 
-let load_ocamlinit () =
-  if Sys.file_exists ".ocamlinit" then ignore(use_silently ".ocamlinit")
+let load_ocamlinit ppf =
+  if Sys.file_exists ".ocamlinit" then ignore(use_silently ppf ".ocamlinit")
 
 (* The interactive loop *)
 
 exception PPerror
 
-let loop() =
-  print_string "        Objective Caml version ";
-  print_string Config.version;
-  print_newline(); print_newline();
+let loop ppf =
+  fprintf ppf "        Objective Caml version %s@.@." Config.version;
   (* Add whatever -I options have been specified on the command line,
      but keep the directories that user code linked in with ocamlmktop
      may have added to load_path. *)
@@ -296,27 +277,25 @@ let loop() =
   Location.input_name := "";
   Location.input_lexbuf := Some lb;
   Sys.catch_break true;
-  load_ocamlinit ();
+  load_ocamlinit ppf;
   while true do
     try
       empty_lexbuf lb;
       Location.reset();
       first_line := true;
       let phr = try !parse_toplevel_phrase lb with Exit -> raise PPerror in
-      if !Clflags.dump_parsetree then Printast.top_phrase phr;
-      ignore(execute_phrase true phr)
+      if !Clflags.dump_parsetree then Printast.top_phrase ppf phr;
+      ignore(execute_phrase true ppf phr)
     with
-      End_of_file -> exit 0
-    | Sys.Break ->
-        print_string "Interrupted."; print_newline()
+    | End_of_file -> exit 0
+    | Sys.Break -> fprintf ppf "Interrupted.@."
     | PPerror -> ()
-    | x ->
-        Errors.report_error x
+    | x -> Errors.report_error ppf x
   done
 
 (* Execute a script *)
 
-let run_script name args =
+let run_script ppf name args =
   let rec find n =
     if n >= Array.length args then invalid_arg "Toploop.run_script";
     if args.(n) = name then n else find (n+1) 
@@ -328,5 +307,5 @@ let run_script name args =
   Obj.truncate (Obj.repr Sys.argv) len;
   Compile.init_path();
   toplevel_env := Compile.initial_env();
-  Formatmsg.set_output Format.err_formatter;
-  use_silently name
+(*  Formatmsg.set_output Format.err_formatter;*)
+  use_silently ppf name
diff --git a/toplevel/toploop.mli b/toplevel/toploop.mli
index 945065b19d..e8fe874d98 100644
--- a/toplevel/toploop.mli
+++ b/toplevel/toploop.mli
@@ -12,37 +12,39 @@
 
 (* $Id$ *)
 
+open Format
+
 (* The interactive toplevel loop *)
 
-val loop: unit -> unit
+val loop : formatter -> unit
 
 (* Read and execute a script from the given file *)
 
-val run_script: string -> string array -> bool
+val run_script : formatter -> string -> string array -> bool
         (* true if successful, false if error *)
 
 (* Interface with toplevel directives *)
 
 type directive_fun =
-    Directive_none of (unit -> unit)
-  | Directive_string of (string -> unit)
-  | Directive_int of (int -> unit)
-  | Directive_ident of (Longident.t -> unit)
-  | Directive_bool of (bool -> unit)
+   | Directive_none of (unit -> unit)
+   | Directive_string of (string -> unit)
+   | Directive_int of (int -> unit)
+   | Directive_ident of (Longident.t -> unit)
+   | Directive_bool of (bool -> unit)
 
-val directive_table: (string, directive_fun) Hashtbl.t
+val directive_table : (string, directive_fun) Hashtbl.t
         (* Table of known directives, with their execution function *)
-val toplevel_env: Env.t ref
+val toplevel_env : Env.t ref
         (* Typing environment for the toplevel *)
-val print_exception_outcome: exn -> unit
+val print_exception_outcome : formatter -> exn -> unit
         (* Print an exception resulting from the evaluation of user code. *)
-val execute_phrase: bool -> Parsetree.toplevel_phrase -> bool
+val execute_phrase : bool -> formatter -> Parsetree.toplevel_phrase -> bool
         (* Execute the given toplevel phrase. Return [true] if the
            phrase executed with no errors and [false] otherwise.
            First bool says whether the values and types of the results
            should be printed. Uncaught exceptions are always printed. *)
-val use_file: string -> bool
-val use_silently: string -> bool
+val use_file : formatter -> string -> bool
+val use_silently : formatter -> string -> bool
         (* Read and execute commands from a file.
            [use_file] prints the types and values of the results.
            [use_silently] does not print them. *)
@@ -51,6 +53,6 @@ val use_silently: string -> bool
 
 val parse_toplevel_phrase : (Lexing.lexbuf -> Parsetree.toplevel_phrase) ref
 val parse_use_file : (Lexing.lexbuf -> Parsetree.toplevel_phrase list) ref
-val print_location : Location.t -> unit
-val print_warning : Location.t -> Warnings.t -> unit
+val print_location : formatter -> Location.t -> unit
+val print_warning : Location.t -> formatter -> Warnings.t -> unit
 val input_name : string ref
diff --git a/toplevel/topmain.ml b/toplevel/topmain.ml
index f7791cf50d..79468b1ab8 100644
--- a/toplevel/topmain.ml
+++ b/toplevel/topmain.ml
@@ -17,7 +17,7 @@ open Clflags
 let usage = "Usage: ocaml <options> [script-file]\noptions are:"
 
 let file_argument name =
-  exit (if Toploop.run_script name Sys.argv then 0 else 2)
+  exit (if Toploop.run_script Format.err_formatter name Sys.argv then 0 else 2)
 
 let main () =
   Arg.parse [
@@ -45,6 +45,6 @@ let main () =
      "-dlambda", Arg.Set dump_lambda, " (undocumented)";
      "-dinstr", Arg.Set dump_instr, " (undocumented)"
     ] file_argument usage;
-  Toploop.loop()
+  Toploop.loop Format.err_formatter
 
 let _ = Printexc.catch main ()
diff --git a/toplevel/trace.ml b/toplevel/trace.ml
index 46d60919bc..e76d3e1696 100644
--- a/toplevel/trace.ml
+++ b/toplevel/trace.ml
@@ -14,7 +14,7 @@
 
 (* The "trace" facility *)
 
-open Formatmsg
+open Format
 open Misc
 open Longident
 open Types
@@ -55,78 +55,66 @@ 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
+let print_label ppf l = if l <> "" then fprintf ppf "%s:" l
 
 (* If a function returns a functional value, wrap it into a trace code *)
 
-let rec instrument_result env name clos_typ =
+let rec instrument_result env name ppf clos_typ =
   match (Ctype.repr(Ctype.expand_head env clos_typ)).desc with
-    Tarrow(l, t1, t2) ->
+  | Tarrow(l, t1, t2) ->
       let starred_name =
         match name with
-          Lident s -> Lident(s ^ "*")
+        | Lident s -> Lident(s ^ "*")
         | Ldot(lid, s) -> Ldot(lid, s ^ "*")
         | Lapply(l1, l2) -> fatal_error "Trace.instrument_result" in
-      let trace_res = instrument_result env starred_name t2 in
+      let trace_res = instrument_result env starred_name ppf t2 in
       (fun clos_val ->
         Obj.repr (fun arg ->
-          open_box 2;
-          Printtyp.longident starred_name;
-          print_string " <--"; print_space();
-          print_label l;
-          print_value !toplevel_env arg t1;
-          close_box(); print_newline();
+          fprintf ppf "@[<2>%a <--@ %a%a@]@."
+          Printtyp.longident starred_name
+          print_label l
+          (print_value !toplevel_env arg) t1;
           try
             let res = (Obj.magic clos_val : Obj.t -> Obj.t) arg in
-            open_box 2;
-            Printtyp.longident starred_name;
-            print_string " -->"; print_space();
-            print_value !toplevel_env res t2;
-            close_box(); print_newline();
+            fprintf ppf "@[<2>%a -->@ %a@]@."
+            Printtyp.longident starred_name
+            (print_value !toplevel_env res) t2;
             trace_res res
           with exn ->
-            open_box 2;
-            Printtyp.longident starred_name; print_string " raises";
-            print_space(); print_exception (Obj.repr exn); close_box();
-            print_newline();
+            fprintf ppf "@[<2>%a raises@ %a@]@."
+            Printtyp.longident starred_name
+            print_exception (Obj.repr exn);
             raise exn))
   | _ -> (fun v -> v)
 
 (* Same as instrument_result, but for a toplevel closure (modified in place) *)
 
-let instrument_closure env name clos_typ =
+let instrument_closure env name ppf clos_typ =
   match (Ctype.repr(Ctype.expand_head env clos_typ)).desc with
-    Tarrow(l, t1, t2) ->
-      let trace_res = instrument_result env name t2 in
+  | Tarrow(l, t1, t2) ->
+      let trace_res = instrument_result env name ppf 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();
+        fprintf ppf "@[<2>%a <--@ %a%a@]@."
+        Printtyp.longident name
+        print_label l
+        (print_value !toplevel_env arg) t1;
         try
           let res = invoke_traced_function actual_code closure arg in
-          open_box 2;
-          Printtyp.longident name; print_string " -->"; print_space();
-          print_value !toplevel_env res t2;
-          close_box(); print_newline();
+          fprintf ppf "@[<2>%a -->@ %a@]@."
+          Printtyp.longident name
+          (print_value !toplevel_env res) t2;
           trace_res res
         with exn ->
-          open_box 2;
-          Printtyp.longident name; print_string " raises";
-          print_space(); print_exception (Obj.repr exn); close_box();
-          print_newline();
+          fprintf ppf "@[<2>%a raises@ %a@]@."
+          Printtyp.longident name
+          print_exception (Obj.repr exn);
           raise exn)
   | _ -> assert false
 
 (* Given the address of a closure, find its tracing info *)
 
 let rec find_traced_closure clos = function
-    [] -> fatal_error "Trace.find_traced_closure"
+  | [] -> fatal_error "Trace.find_traced_closure"
   | f :: rem -> if f.closure == clos then f else find_traced_closure clos rem
 
 (* Trace the application of an (instrumented) closure to an argument *)
diff --git a/toplevel/trace.mli b/toplevel/trace.mli
index 67bdc54c35..ed7dc6e33a 100644
--- a/toplevel/trace.mli
+++ b/toplevel/trace.mli
@@ -14,6 +14,8 @@
 
 (* The "trace" facility *)
 
+open Format
+
 type codeptr
 
 type traced_function =
@@ -28,6 +30,6 @@ val is_traced: Obj.t -> Path.t option
 val get_code_pointer: Obj.t -> codeptr
 val set_code_pointer: Obj.t -> codeptr -> unit
 val instrument_closure:
-        Env.t -> Longident.t -> Types.type_expr -> 
+        Env.t -> Longident.t -> formatter -> Types.type_expr -> 
         codeptr -> Obj.t -> Obj.t -> Obj.t
 val print_trace: Obj.t -> Obj.t -> Obj.t