Revu les impressions du compilateur

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

73 files changed, 2213 insertions, 2640 deletions

diff --git a/bytecomp/bytelibrarian.ml b/bytecomp/bytelibrarian.ml
index 6afebce17..5247bac04 100644
--- a/bytecomp/bytelibrarian.ml
+++ b/bytecomp/bytelibrarian.ml
@@ -83,11 +83,11 @@ let create_archive file_list lib_name =
     remove_file lib_name;
     raise x
 
-open Formatmsg
+open Format
 
-let report_error = function
-    File_not_found name ->
-      printf "Cannot find file %s" name
+let report_error ppf = function
+  | File_not_found name ->
+      fprintf ppf "Cannot find file %s" name
   | Not_an_object_file name ->
-      printf "The file %s is not a bytecode object file" name
+      fprintf ppf "The file %s is not a bytecode object file" name
 
diff --git a/bytecomp/bytelibrarian.mli b/bytecomp/bytelibrarian.mli
index 783486420..a4f9cc2f2 100644
--- a/bytecomp/bytelibrarian.mli
+++ b/bytecomp/bytelibrarian.mli
@@ -29,4 +29,6 @@ type error =
 
 exception Error of error
 
-val report_error: error -> unit
+open Format
+
+val report_error: formatter -> error -> unit
diff --git a/bytecomp/bytelink.ml b/bytecomp/bytelink.ml
index 6b09258bc..b03b62aec 100644
--- a/bytecomp/bytelink.ml
+++ b/bytecomp/bytelink.ml
@@ -508,22 +508,22 @@ let link objfiles =
 
 (* Error report *)
 
-open Formatmsg
+open Format
 
-let report_error = function
-    File_not_found name ->
-      printf "Cannot find file %s" name
+let report_error ppf = function
+  | File_not_found name ->
+      fprintf ppf "Cannot find file %s" name
   | Not_an_object_file name ->
-      printf "The file %s is not a bytecode object file" name
+      fprintf ppf "The file %s is not a bytecode object file" name
   | Symbol_error(name, err) ->
-      printf "Error while linking %s:@ " name;
+      fprintf ppf "Error while linking %s:@ %a" name
       Symtable.report_error err
   | Inconsistent_import(intf, file1, file2) ->
-      printf
+      fprintf ppf
         "@[<hv 0>Files %s and %s@ \
                  make inconsistent assumptions over interface %s@]"
         file1 file2 intf
   | Custom_runtime ->
-      print_string "Error while building custom runtime system"
+      fprintf ppf "Error while building custom runtime system"
   | File_exists file ->
-      printf "Cannot overwrite existing file %s" file
+      fprintf ppf "Cannot overwrite existing file %s" file
diff --git a/bytecomp/bytelink.mli b/bytecomp/bytelink.mli
index 637bfa2b8..d3b932e29 100644
--- a/bytecomp/bytelink.mli
+++ b/bytecomp/bytelink.mli
@@ -28,4 +28,6 @@ type error =
 
 exception Error of error
 
-val report_error: error -> unit
+open Format
+
+val report_error: formatter -> error -> unit
diff --git a/bytecomp/printinstr.ml b/bytecomp/printinstr.ml
index 1109670d4..3486b540c 100644
--- a/bytecomp/printinstr.ml
+++ b/bytecomp/printinstr.ml
@@ -14,100 +14,97 @@
 
 (* Pretty-print lists of instructions *)
 
-open Formatmsg
+open Format
 open Lambda
 open Instruct
 
 
-let instruct ppf = function
-    Klabel lbl -> printf "L%i:" lbl
-  | Kacc n -> printf "\tacc %i" n
-  | Kenvacc n -> printf "\tenvacc %i" n
-  | Kpush -> print_string "\tpush"
-  | Kpop n -> printf "\tpop %i" n
-  | Kassign n -> printf "\tassign %i" n
-  | Kpush_retaddr lbl -> printf "\tpush_retaddr L%i" lbl
-  | Kapply n -> printf "\tapply %i" n
+let instruction ppf = function
+  | Klabel lbl -> fprintf ppf "L%i:" lbl
+  | Kacc n -> fprintf ppf "\tacc %i" n
+  | Kenvacc n -> fprintf ppf "\tenvacc %i" n
+  | Kpush -> fprintf ppf "\tpush"
+  | Kpop n -> fprintf ppf "\tpop %i" n
+  | Kassign n -> fprintf ppf "\tassign %i" n
+  | Kpush_retaddr lbl -> fprintf ppf "\tpush_retaddr L%i" lbl
+  | Kapply n -> fprintf ppf "\tapply %i" n
   | Kappterm(n, m) ->
-      printf "\tappterm %i, %i" n m
-  | Kreturn n -> printf "\treturn %i" n
-  | Krestart -> print_string "\trestart"
-  | Kgrab n -> printf "\tgrab %i" n
+      fprintf ppf "\tappterm %i, %i" n m
+  | Kreturn n -> fprintf ppf "\treturn %i" n
+  | Krestart -> fprintf ppf "\trestart"
+  | Kgrab n -> fprintf ppf "\tgrab %i" n
   | Kclosure(lbl, n) ->
-      printf "\tclosure L%i, %i" lbl n
+      fprintf ppf "\tclosure L%i, %i" lbl n
   | Kclosurerec(lbls, n) ->
-      print_string "\tclosurerec";
-      List.iter (fun lbl -> printf " %i" lbl) lbls;
-      printf ", %i" n
-  | Koffsetclosure n -> printf "\toffsetclosure %i" n
-  | Kgetglobal id -> print_string "\tgetglobal "; Ident.print id
-  | Ksetglobal id -> print_string "\tsetglobal "; Ident.print id
+      fprintf ppf "\tclosurerec";
+      List.iter (fun lbl -> fprintf ppf " %i" lbl) lbls;
+      fprintf ppf ", %i" n
+  | Koffsetclosure n -> fprintf ppf "\toffsetclosure %i" n
+  | Kgetglobal id -> fprintf ppf "\tgetglobal "; Ident.print id
+  | Ksetglobal id -> fprintf ppf "\tsetglobal "; Ident.print id
   | Kconst cst ->
-      let pr_constant ppf cst = Printlambda.structured_constant cst in
-      printf "@[<10>\tconst@ %a@]" pr_constant cst
+      fprintf ppf "@[<10>\tconst@ %a@]" Printlambda.structured_constant cst
   | Kmakeblock(n, m) ->
-      printf "\tmakeblock %i, %i" n m
+      fprintf ppf "\tmakeblock %i, %i" n m
   | Kmakefloatblock(n) ->
-      printf "\tmakefloatblock %i" n
-  | Kgetfield n -> printf "\tgetfield %i" n
-  | Ksetfield n -> printf "\tsetfield %i" n
-  | Kgetfloatfield n -> printf "\tgetfloatfield %i" n
-  | Ksetfloatfield n -> printf "\tsetfloatfield %i" n
-  | Kvectlength -> print_string "\tvectlength"
-  | Kgetvectitem -> print_string "\tgetvectitem"
-  | Ksetvectitem -> print_string "\tsetvectitem"
-  | Kgetstringchar -> print_string "\tgetstringchar"
-  | Ksetstringchar -> print_string "\tsetstringchar"
-  | Kbranch lbl -> printf "\tbranch L%i" lbl
-  | Kbranchif lbl -> printf "\tbranchif L%i" lbl
-  | Kbranchifnot lbl -> printf "\tbranchifnot L%i" lbl
-  | Kstrictbranchif lbl -> printf "\tstrictbranchif L%i" lbl
+      fprintf ppf "\tmakefloatblock %i" n
+  | Kgetfield n -> fprintf ppf "\tgetfield %i" n
+  | Ksetfield n -> fprintf ppf "\tsetfield %i" n
+  | Kgetfloatfield n -> fprintf ppf "\tgetfloatfield %i" n
+  | Ksetfloatfield n -> fprintf ppf "\tsetfloatfield %i" n
+  | Kvectlength -> fprintf ppf "\tvectlength"
+  | Kgetvectitem -> fprintf ppf "\tgetvectitem"
+  | Ksetvectitem -> fprintf ppf "\tsetvectitem"
+  | Kgetstringchar -> fprintf ppf "\tgetstringchar"
+  | Ksetstringchar -> fprintf ppf "\tsetstringchar"
+  | Kbranch lbl -> fprintf ppf "\tbranch L%i" lbl
+  | Kbranchif lbl -> fprintf ppf "\tbranchif L%i" lbl
+  | Kbranchifnot lbl -> fprintf ppf "\tbranchifnot L%i" lbl
+  | Kstrictbranchif lbl -> fprintf ppf "\tstrictbranchif L%i" lbl
   | Kstrictbranchifnot lbl ->
-      printf "\tstrictbranchifnot L%i" lbl
+      fprintf ppf "\tstrictbranchifnot L%i" lbl
   | Kswitch(consts, blocks) ->
       let labels ppf labs =
-        Array.iter (fun lbl -> printf "@ %i" lbl) labs in
-      printf "@[<10>\tswitch%a/%a@]" labels consts labels blocks
-  | Kboolnot -> print_string "\tboolnot"
-  | Kpushtrap lbl -> printf "\tpushtrap L%i" lbl
-  | Kpoptrap -> print_string "\tpoptrap"
-  | Kraise -> print_string "\traise"
-  | Kcheck_signals -> print_string "\tcheck_signals"
+        Array.iter (fun lbl -> fprintf ppf "@ %i" lbl) labs in
+      fprintf ppf "@[<10>\tswitch%a/%a@]" labels consts labels blocks
+  | Kboolnot -> fprintf ppf "\tboolnot"
+  | Kpushtrap lbl -> fprintf ppf "\tpushtrap L%i" lbl
+  | Kpoptrap -> fprintf ppf "\tpoptrap"
+  | Kraise -> fprintf ppf "\traise"
+  | Kcheck_signals -> fprintf ppf "\tcheck_signals"
   | Kccall(s, n) ->
-      printf "\tccall %s, %i" s n
-  | Knegint -> print_string "\tnegint"
-  | Kaddint -> print_string "\taddint"
-  | Ksubint -> print_string "\tsubint"
-  | Kmulint -> print_string "\tmulint"
-  | Kdivint -> print_string "\tdivint"
-  | Kmodint -> print_string "\tmodint"
-  | Kandint -> print_string "\tandint"
-  | Korint -> print_string "\torint"
-  | Kxorint -> print_string "\txorint"
-  | Klslint -> print_string "\tlslint"
-  | Klsrint -> print_string "\tlsrint"
-  | Kasrint -> print_string "\tasrint"
-  | Kintcomp Ceq -> print_string "\teqint"
-  | Kintcomp Cneq -> print_string "\tneqint"
-  | Kintcomp Clt -> print_string "\tltint"
-  | Kintcomp Cgt -> print_string "\tgtint"
-  | Kintcomp Cle -> print_string "\tleint"
-  | Kintcomp Cge -> print_string "\tgeint"
-  | Koffsetint n -> printf "\toffsetint %i" n
-  | Koffsetref n -> printf "\toffsetref %i" n
-  | Kisint -> print_string "\tisint"
-  | Kgetmethod -> print_string "\tgetmethod"
-  | Kstop -> print_string "\tstop"
-  | Kevent ev -> printf "\tevent %i" ev.ev_char
+      fprintf ppf "\tccall %s, %i" s n
+  | Knegint -> fprintf ppf "\tnegint"
+  | Kaddint -> fprintf ppf "\taddint"
+  | Ksubint -> fprintf ppf "\tsubint"
+  | Kmulint -> fprintf ppf "\tmulint"
+  | Kdivint -> fprintf ppf "\tdivint"
+  | Kmodint -> fprintf ppf "\tmodint"
+  | Kandint -> fprintf ppf "\tandint"
+  | Korint -> fprintf ppf "\torint"
+  | Kxorint -> fprintf ppf "\txorint"
+  | Klslint -> fprintf ppf "\tlslint"
+  | Klsrint -> fprintf ppf "\tlsrint"
+  | Kasrint -> fprintf ppf "\tasrint"
+  | Kintcomp Ceq -> fprintf ppf "\teqint"
+  | Kintcomp Cneq -> fprintf ppf "\tneqint"
+  | Kintcomp Clt -> fprintf ppf "\tltint"
+  | Kintcomp Cgt -> fprintf ppf "\tgtint"
+  | Kintcomp Cle -> fprintf ppf "\tleint"
+  | Kintcomp Cge -> fprintf ppf "\tgeint"
+  | Koffsetint n -> fprintf ppf "\toffsetint %i" n
+  | Koffsetref n -> fprintf ppf "\toffsetref %i" n
+  | Kisint -> fprintf ppf "\tisint"
+  | Kgetmethod -> fprintf ppf "\tgetmethod"
+  | Kstop -> fprintf ppf "\tstop"
+  | Kevent ev -> fprintf ppf "\tevent %i" ev.ev_char
 
 let rec instruction_list ppf = function
     [] -> ()
   | Klabel lbl :: il ->
-      printf "L%i:%a" lbl instruction_list il
+      fprintf ppf "L%i:%a" lbl instruction_list il
   | instr :: il ->
-      printf "%a@ %a" instruct instr instruction_list il
+      fprintf ppf "%a@ %a" instruction instr instruction_list il
  
-let instrlist il =
-  printf "@[<v 0>%a@]" instruction_list il
-
-let instruction i = printf "%a" instruct i
+let instrlist ppf il =
+  fprintf ppf "@[<v 0>%a@]" instruction_list il
diff --git a/bytecomp/printinstr.mli b/bytecomp/printinstr.mli
index f05373739..e88e76ffc 100644
--- a/bytecomp/printinstr.mli
+++ b/bytecomp/printinstr.mli
@@ -16,5 +16,7 @@
 
 open Instruct
 
-val instruction: instruction -> unit
-val instrlist: instruction list -> unit
+open Format
+
+val instruction: formatter -> instruction -> unit
+val instrlist: formatter -> instruction list -> unit
diff --git a/bytecomp/printlambda.ml b/bytecomp/printlambda.ml
index 78ded6184..6e70043cc 100644
--- a/bytecomp/printlambda.ml
+++ b/bytecomp/printlambda.ml
@@ -12,7 +12,7 @@
 
 (* $Id$ *)
 
-open Formatmsg
+open Format
 open Asttypes
 open Primitive
 open Types
@@ -20,254 +20,262 @@ open Lambda
 
 
 let rec struct_const ppf = function
-    Const_base(Const_int n) -> print_int n
+  | Const_base(Const_int n) -> fprintf ppf "%i" n
   | Const_base(Const_char c) ->
-      printf "'%s'" (Char.escaped c)
+      fprintf ppf "'%s'" (Char.escaped c)
   | Const_base(Const_string s) ->
-      printf "\"%s\"" (String.escaped s)
+      fprintf ppf "\"%s\"" (String.escaped s)
   | Const_base(Const_float s) ->
-      print_string s
-  | Const_pointer n -> printf "%ia" n
+      fprintf ppf "%s" s
+  | Const_pointer n -> fprintf ppf "%ia" n
   | Const_block(tag, []) ->
-      printf "[%i]" tag
+      fprintf ppf "[%i]" tag
   | Const_block(tag, sc1::scl) ->
       let sconsts ppf scl =
-        List.iter (fun sc -> printf "@ %a" struct_const sc) scl in
-      printf "@[<1>[%i:@ @[%a%a@]]@]" tag struct_const sc1 sconsts scl
+        List.iter (fun sc -> fprintf ppf "@ %a" struct_const sc) scl in
+      fprintf ppf "@[<1>[%i:@ @[%a%a@]]@]" tag struct_const sc1 sconsts scl
   | Const_float_array [] ->
-      print_string "[| |]"
+      fprintf ppf "[| |]"
   | Const_float_array (f1 :: fl) ->
       let floats ppf fl =
-        List.iter (fun f -> print_space(); print_string f) fl in
-      printf "@[<1[|@[%s%a@]|]@]" f1 floats fl
+        List.iter (fun f -> fprintf ppf "@ %s" f) fl in
+      fprintf ppf "@[<1[|@[%s%a@]|]@]" f1 floats fl
 
 let print_id ppf id = Ident.print id
 
 let boxed_integer_name = function
-    Pnativeint -> "nativeint"
+  | Pnativeint -> "nativeint"
   | Pint32 -> "int32"
   | Pint64 -> "int64"
 
-let print_boxed_integer name bi =
-  printf "%s_%s" (boxed_integer_name bi) name
+let print_boxed_integer name ppf bi =
+  fprintf ppf "%s_%s" (boxed_integer_name bi) name
 
 let print_boxed_integer_conversion bi1 bi2 =
   printf "%s_of_%s" (boxed_integer_name bi2) (boxed_integer_name bi1)
 
-let print_bigarray name kind layout =
-  printf "Bigarray.%s[%s,%s]"
-         name
-         (match kind with
-            Pbigarray_unknown -> "generic"
-          | Pbigarray_float32 -> "float32"
-          | Pbigarray_float64 -> "float64"
-          | Pbigarray_sint8 -> "sint8"
-          | Pbigarray_uint8 -> "uint8"
-          | Pbigarray_sint16 -> "sint16"
-          | Pbigarray_uint16 -> "uint16"
-          | Pbigarray_int32 -> "int32"
-          | Pbigarray_int64 -> "int64"
-          | Pbigarray_caml_int -> "camlint"
-          | Pbigarray_native_int -> "nativeint")
-         (match layout with
-            Pbigarray_unknown_layout -> "unknown"
-          | Pbigarray_c_layout -> "C"
-          | Pbigarray_fortran_layout -> "Fortran")
+let boxed_integer_mark name = function
+  | Pnativeint -> Printf.sprintf "Nativeint.%s" name
+  | Pint32 -> Printf.sprintf "Int32.%s" name
+  | Pint64 -> Printf.sprintf "Int64.%s" name
+
+let print_boxed_integer name ppf bi =
+  fprintf ppf "%s" (boxed_integer_mark name bi);;
+
+let print_bigarray name kind ppf layout =
+  fprintf ppf "Bigarray.%s[%s,%s]"
+    name
+    (match kind with
+     | Pbigarray_unknown -> "generic"
+     | Pbigarray_float32 -> "float32"
+     | Pbigarray_float64 -> "float64"
+     | Pbigarray_sint8 -> "sint8"
+     | Pbigarray_uint8 -> "uint8"
+     | Pbigarray_sint16 -> "sint16"
+     | Pbigarray_uint16 -> "uint16"
+     | Pbigarray_int32 -> "int32"
+     | Pbigarray_int64 -> "int64"
+     | Pbigarray_caml_int -> "camlint"
+     | Pbigarray_native_int -> "nativeint")
+    (match layout with
+    |  Pbigarray_unknown_layout -> "unknown"
+     | Pbigarray_c_layout -> "C"
+     | Pbigarray_fortran_layout -> "Fortran")
 
 let primitive ppf = function
-    Pidentity -> print_string "id"
-  | Pignore -> print_string "ignore"
-  | Pgetglobal id -> printf "global %a" print_id id
-  | Psetglobal id -> printf "setglobal %a" print_id id
-  | Pmakeblock(tag, Immutable) -> printf "makeblock %i" tag
-  | Pmakeblock(tag, Mutable) -> printf "makemutable %i" tag
-  | Pfield n -> printf "field %i" n
+  | Pidentity -> fprintf ppf "id"
+  | Pignore -> fprintf ppf "ignore"
+  | Pgetglobal id -> fprintf ppf "global %a" print_id id
+  | Psetglobal id -> fprintf ppf "setglobal %a" print_id id
+  | Pmakeblock(tag, Immutable) -> fprintf ppf "makeblock %i" tag
+  | Pmakeblock(tag, Mutable) -> fprintf ppf "makemutable %i" tag
+  | Pfield n -> fprintf ppf "field %i" n
   | Psetfield(n, ptr) ->
-      print_string (if ptr then "setfield_ptr " else "setfield_imm ");
-      print_int n
-  | Pfloatfield n -> printf "floatfield %i" n
-  | Psetfloatfield n -> printf "setfloatfield %i" n
-  | Pccall p -> print_string p.prim_name
-  | Praise -> print_string "raise"
-  | Psequand -> print_string "&&"
-  | Psequor -> print_string "||"
-  | Pnot -> print_string "not"
-  | Pnegint -> print_string "~"
-  | Paddint -> print_string "+"
-  | Psubint -> print_string "-"
-  | Pmulint -> print_string "*"
-  | Pdivint -> print_string "/"
-  | Pmodint -> print_string "mod"
-  | Pandint -> print_string "and"
-  | Porint -> print_string "or"
-  | Pxorint -> print_string "xor"
-  | Plslint -> print_string "lsl"
-  | Plsrint -> print_string "lsr"
-  | Pasrint -> print_string "asr"
-  | Pintcomp(Ceq) -> print_string "=="
-  | Pintcomp(Cneq) -> print_string "!="
-  | Pintcomp(Clt) -> print_string "<"
-  | Pintcomp(Cle) -> print_string "<="
-  | Pintcomp(Cgt) -> print_string ">"
-  | Pintcomp(Cge) -> print_string ">="
-  | Poffsetint n -> print_int n; print_string "+"
-  | Poffsetref n -> print_int n; print_string "+:="
-  | Pintoffloat -> print_string "int_of_float"
-  | Pfloatofint -> print_string "float_of_int"
-  | Pnegfloat -> print_string "~."
-  | Pabsfloat -> print_string "abs."
-  | Paddfloat -> print_string "+."
-  | Psubfloat -> print_string "-."
-  | Pmulfloat -> print_string "*."
-  | Pdivfloat -> print_string "/."
-  | Pfloatcomp(Ceq) -> print_string "==."
-  | Pfloatcomp(Cneq) -> print_string "!=."
-  | Pfloatcomp(Clt) -> print_string "<."
-  | Pfloatcomp(Cle) -> print_string "<=."
-  | Pfloatcomp(Cgt) -> print_string ">."
-  | Pfloatcomp(Cge) -> print_string ">=."
-  | Pstringlength -> print_string "string.length"
-  | Pstringrefu -> print_string "string.unsafe_get"
-  | Pstringsetu -> print_string "string.unsafe_set"
-  | Pstringrefs -> print_string "string.get"
-  | Pstringsets -> print_string "string.set"
-  | Parraylength _ -> print_string "array.length"
-  | Pmakearray _ -> print_string "makearray "
-  | Parrayrefu _ -> print_string "array.unsafe_get"
-  | Parraysetu _ -> print_string "array.unsafe_set"
-  | Parrayrefs _ -> print_string "array.get"
-  | Parraysets _ -> print_string "array.set"
-  | Pisint -> print_string "isint"
-  | Pbittest -> print_string "testbit"
-  | Pbintofint bi -> print_boxed_integer "of_int" bi
-  | Pintofbint bi -> print_boxed_integer "to_int" bi
-  | Pcvtbint(bi1, bi2) -> print_boxed_integer_conversion bi1 bi2
-  | Pnegbint bi -> print_boxed_integer "neg" bi
-  | Paddbint bi -> print_boxed_integer "add" bi
-  | Psubbint bi -> print_boxed_integer "sub" bi
-  | Pmulbint bi -> print_boxed_integer "mul" bi
-  | Pdivbint bi -> print_boxed_integer "div" bi
-  | Pmodbint bi -> print_boxed_integer "mod" bi
-  | Pandbint bi -> print_boxed_integer "and" bi
-  | Porbint bi -> print_boxed_integer "or" bi
-  | Pxorbint bi -> print_boxed_integer "xor" bi
-  | Plslbint bi -> print_boxed_integer "lsl" bi
-  | Plsrbint bi -> print_boxed_integer "lsr" bi
-  | Pasrbint bi -> print_boxed_integer "asr" bi
-  | Pbintcomp(bi, Ceq) -> print_boxed_integer "==" bi
-  | Pbintcomp(bi, Cneq) -> print_boxed_integer "!=" bi
-  | Pbintcomp(bi, Clt) -> print_boxed_integer "<" bi
-  | Pbintcomp(bi, Cgt) -> print_boxed_integer ">" bi
-  | Pbintcomp(bi, Cle) -> print_boxed_integer "<=" bi
-  | Pbintcomp(bi, Cge) -> print_boxed_integer ">=" bi
-  | Pbigarrayref(n, kind, layout) -> print_bigarray "get" kind layout
-  | Pbigarrayset(n, kind, layout) -> print_bigarray "set" kind layout
+      let instr = if ptr then "setfield_ptr " else "setfield_imm " in
+      fprintf ppf "%s%i" instr n
+  | Pfloatfield n -> fprintf ppf "floatfield %i" n
+  | Psetfloatfield n -> fprintf ppf "setfloatfield %i" n
+  | Pccall p -> fprintf ppf "%s" p.prim_name
+  | Praise -> fprintf ppf "raise"
+  | Psequand -> fprintf ppf "&&"
+  | Psequor -> fprintf ppf "||"
+  | Pnot -> fprintf ppf "not"
+  | Pnegint -> fprintf ppf "~"
+  | Paddint -> fprintf ppf "+"
+  | Psubint -> fprintf ppf "-"
+  | Pmulint -> fprintf ppf "*"
+  | Pdivint -> fprintf ppf "/"
+  | Pmodint -> fprintf ppf "mod"
+  | Pandint -> fprintf ppf "and"
+  | Porint -> fprintf ppf "or"
+  | Pxorint -> fprintf ppf "xor"
+  | Plslint -> fprintf ppf "lsl"
+  | Plsrint -> fprintf ppf "lsr"
+  | Pasrint -> fprintf ppf "asr"
+  | Pintcomp(Ceq) -> fprintf ppf "=="
+  | Pintcomp(Cneq) -> fprintf ppf "!="
+  | Pintcomp(Clt) -> fprintf ppf "<"
+  | Pintcomp(Cle) -> fprintf ppf "<="
+  | Pintcomp(Cgt) -> fprintf ppf ">"
+  | Pintcomp(Cge) -> fprintf ppf ">="
+  | Poffsetint n -> fprintf ppf "%i+" n
+  | Poffsetref n -> fprintf ppf "+:=%i"n
+  | Pintoffloat -> fprintf ppf "int_of_float"
+  | Pfloatofint -> fprintf ppf "float_of_int"
+  | Pnegfloat -> fprintf ppf "~."
+  | Pabsfloat -> fprintf ppf "abs."
+  | Paddfloat -> fprintf ppf "+."
+  | Psubfloat -> fprintf ppf "-."
+  | Pmulfloat -> fprintf ppf "*."
+  | Pdivfloat -> fprintf ppf "/."
+  | Pfloatcomp(Ceq) -> fprintf ppf "==."
+  | Pfloatcomp(Cneq) -> fprintf ppf "!=."
+  | Pfloatcomp(Clt) -> fprintf ppf "<."
+  | Pfloatcomp(Cle) -> fprintf ppf "<=."
+  | Pfloatcomp(Cgt) -> fprintf ppf ">."
+  | Pfloatcomp(Cge) -> fprintf ppf ">=."
+  | Pstringlength -> fprintf ppf "string.length"
+  | Pstringrefu -> fprintf ppf "string.unsafe_get"
+  | Pstringsetu -> fprintf ppf "string.unsafe_set"
+  | Pstringrefs -> fprintf ppf "string.get"
+  | Pstringsets -> fprintf ppf "string.set"
+  | Parraylength _ -> fprintf ppf "array.length"
+  | Pmakearray _ -> fprintf ppf "makearray "
+  | Parrayrefu _ -> fprintf ppf "array.unsafe_get"
+  | Parraysetu _ -> fprintf ppf "array.unsafe_set"
+  | Parrayrefs _ -> fprintf ppf "array.get"
+  | Parraysets _ -> fprintf ppf "array.set"
+  | Pisint -> fprintf ppf "isint"
+  | Pbittest -> fprintf ppf "testbit"
+  | Pbintofint bi -> print_boxed_integer "of_int" ppf bi
+  | Pintofbint bi -> print_boxed_integer "to_int" ppf bi
+  | Pnegbint bi -> print_boxed_integer "neg" ppf bi
+  | Paddbint bi -> print_boxed_integer "add" ppf bi
+  | Psubbint bi -> print_boxed_integer "sub" ppf bi
+  | Pmulbint bi -> print_boxed_integer "mul" ppf bi
+  | Pdivbint bi -> print_boxed_integer "div" ppf bi
+  | Pmodbint bi -> print_boxed_integer "mod" ppf bi
+  | Pandbint bi -> print_boxed_integer "and" ppf bi
+  | Porbint bi -> print_boxed_integer "or" ppf bi
+  | Pxorbint bi -> print_boxed_integer "xor" ppf bi
+  | Plslbint bi -> print_boxed_integer "lsl" ppf bi
+  | Plsrbint bi -> print_boxed_integer "lsr" ppf bi
+  | Pasrbint bi -> print_boxed_integer "asr" ppf bi
+  | Pbintcomp(bi, Ceq) -> print_boxed_integer "==" ppf bi
+  | Pbintcomp(bi, Cneq) -> print_boxed_integer "!=" ppf bi
+  | Pbintcomp(bi, Clt) -> print_boxed_integer "<" ppf bi
+  | Pbintcomp(bi, Cgt) -> print_boxed_integer ">" ppf bi
+  | Pbintcomp(bi, Cle) -> print_boxed_integer "<=" ppf bi
+  | Pbintcomp(bi, Cge) -> print_boxed_integer ">=" ppf bi
+  | Pbigarrayref(n, kind, layout) -> print_bigarray "get" kind ppf layout
+  | Pbigarrayset(n, kind, layout) -> print_bigarray "set" kind ppf layout
 
 let rec lam ppf = function
-    Lvar id ->
+  | Lvar id ->
       print_id ppf id
   | Lconst cst ->
       struct_const ppf cst
   | Lapply(lfun, largs) ->
       let lams ppf largs =
-        List.iter (fun l -> printf "@ %a" lam l) largs in
-      printf "@[<2>(apply@ %a%a)@]" lam lfun lams largs
+        List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in
+      fprintf ppf "@[<2>(apply@ %a%a)@]" lam lfun lams largs
   | Lfunction(kind, params, body) ->
       let pr_params ppf params =
         match kind with
         | Curried ->
-            List.iter (fun param -> printf "@ %a" print_id param) params
+            List.iter (fun param -> fprintf ppf "@ %a" print_id param) params
         | Tupled ->
-            print_string " (";
+            fprintf ppf " (";
             let first = ref true in
             List.iter
               (fun param ->
-                if !first then first := false else printf ",@ ";
+                if !first then first := false else fprintf ppf ",@ ";
                 print_id ppf param)
               params;
-            print_string ")" in
-      printf "@[<2>(function%a@ %a)@]" pr_params params lam body
+            fprintf ppf ")" in
+      fprintf ppf "@[<2>(function%a@ %a)@]" pr_params params lam body
   | Llet(str, id, arg, body) ->
       let rec letbody = function
         | Llet(str, id, arg, body) ->
-            printf "@ @[<2>%a@ %a@]" print_id id lam arg;
+            fprintf ppf "@ @[<2>%a@ %a@]" print_id id lam arg;
             letbody body
         | expr -> expr in
-      printf "@[<2>(let@ @[<hv 1>(@[<2>%a@ %a@]" print_id id lam arg;
+      fprintf ppf "@[<2>(let@ @[<hv 1>(@[<2>%a@ %a@]" print_id id lam arg;
       let expr = letbody body in
-      printf ")@]@ %a)@]" lam expr
+      fprintf ppf ")@]@ %a)@]" lam expr
   | Lletrec(id_arg_list, body) ->
       let bindings ppf id_arg_list =
         let spc = ref false in
         List.iter
           (fun (id, l) ->
             if !spc then print_space() else spc := true;
-            printf "@[<2>%a@ %a@]" print_id id lam l)
+            fprintf ppf "@[<2>%a@ %a@]" print_id id lam l)
           id_arg_list in
-      printf "@[<2>(letrec@ (@[<hv 1>%a@])@ %a)@]" bindings id_arg_list lam body
+      fprintf ppf
+        "@[<2>(letrec@ (@[<hv 1>%a@])@ %a)@]" bindings id_arg_list lam body
   | Lprim(prim, largs) ->
       let lams ppf largs =
-        List.iter (fun l -> printf "@ %a" lam l) largs in
-      printf "@[<2>(%a%a)@]" primitive prim lams largs
+        List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in
+      fprintf ppf "@[<2>(%a%a)@]" primitive prim lams largs
   | Lswitch(larg, sw) ->
       let switch ppf sw =
         let spc = ref false in
         List.iter
          (fun (n, l) ->
            if !spc then print_space() else spc := true;
-           printf "@[<hv 1>case int %i:@ %a@]" n lam l)
+           fprintf ppf "@[<hv 1>case int %i:@ %a@]" n lam l)
          sw.sw_consts;
        List.iter
          (fun (n, l) ->
            if !spc then print_space() else spc := true;
-           printf "@[<hv 1>case tag %i:@ %a@]" n lam l)
+           fprintf ppf "@[<hv 1>case tag %i:@ %a@]" n lam l)
          sw.sw_blocks in
-      printf
+      fprintf ppf
        "@[<1>(%s%a@ @[<v 0>%a@])@]"
        (if sw.sw_checked then "switch-checked " else "switch ")
        lam larg switch sw
   | Lstaticfail ->
-      print_string "exit"
+      fprintf ppf "exit"
   | Lcatch(lbody, lhandler) ->
-      printf "@[<2>(catch@ %a@;<1 -1>with@ %a)@]" lam lbody lam lhandler
+      fprintf ppf "@[<2>(catch@ %a@;<1 -1>with@ %a)@]" lam lbody lam lhandler
   | Ltrywith(lbody, param, lhandler) ->
-      printf "@[<2>(try@ %a@;<1 -1>with %a@ %a)@]"
+      fprintf ppf "@[<2>(try@ %a@;<1 -1>with %a@ %a)@]"
         lam lbody print_id param lam lhandler
   | Lifthenelse(lcond, lif, lelse) ->
-      printf "@[<2>(if@ %a@ %a@ %a)@]" lam lcond lam lif lam lelse
+      fprintf ppf "@[<2>(if@ %a@ %a@ %a)@]" lam lcond lam lif lam lelse
   | Lsequence(l1, l2) ->
-      printf "@[<2>(seq@ %a@ %a)@]" lam l1 sequence l2
+      fprintf ppf "@[<2>(seq@ %a@ %a)@]" lam l1 sequence l2
   | Lwhile(lcond, lbody) ->
-      printf "@[<2>(while@ %a@ %a)@]" lam lcond lam lbody
+      fprintf ppf "@[<2>(while@ %a@ %a)@]" lam lcond lam lbody
   | Lfor(param, lo, hi, dir, body) ->
-      printf "@[<2>(for %a@ %a@ %s@ %a@ %a)@]"
+      fprintf ppf "@[<2>(for %a@ %a@ %s@ %a@ %a)@]"
        print_id param lam lo
        (match dir with Upto -> "to" | Downto -> "downto")
        lam hi lam body
   | Lassign(id, expr) ->
-      printf "@[<2>(assign@ %a@ %a)@]" print_id id lam expr
+      fprintf ppf "@[<2>(assign@ %a@ %a)@]" print_id id lam expr
   | Lsend (met, obj, largs) ->
       let args ppf largs =
-        List.iter (fun l -> printf "@ %a" lam l) largs in
-      printf "@[<2>(send@ %a@ %a%a)@]" lam obj lam met args largs
+        List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in
+      fprintf ppf "@[<2>(send@ %a@ %a%a)@]" lam obj lam met args largs
   | Levent(expr, ev) ->
       let kind = 
        match ev.lev_kind with
        | Lev_before -> "before"
        | Lev_after _  -> "after"
        | Lev_function -> "funct-body" in
-      printf "@[<2>(%s %i@ %a)@]" kind ev.lev_loc lam expr
+      fprintf ppf "@[<2>(%s %i@ %a)@]" kind ev.lev_loc lam expr
   | Lifused(id, expr) ->
-      printf "@[<2>(ifused@ %a@ %a)@]" print_id id lam expr
+      fprintf ppf "@[<2>(ifused@ %a@ %a)@]" print_id id lam expr
 
 and sequence ppf = function
-    Lsequence(l1, l2) ->
-      printf "%a@ %a" sequence l1 sequence l2
+  | Lsequence(l1, l2) ->
+      fprintf ppf "%a@ %a" sequence l1 sequence l2
   | Llet(str, id, arg, body) ->
-      printf "@[<2>let@ %a@ %a@]@ %a" print_id id lam arg sequence body
+      fprintf ppf "@[<2>let@ %a@ %a@]@ %a" print_id id lam arg sequence body
   | l ->
       lam ppf l
 
-let structured_constant cst = printf "%a" struct_const cst
+let structured_constant = struct_const
 
-let lambda l = printf "%a" lam l
+let lambda = lam
diff --git a/bytecomp/printlambda.mli b/bytecomp/printlambda.mli
index a0953a5cc..352d6d024 100644
--- a/bytecomp/printlambda.mli
+++ b/bytecomp/printlambda.mli
@@ -14,5 +14,7 @@
 
 open Lambda
 
-val structured_constant: structured_constant -> unit
-val lambda: lambda -> unit
+open Format
+
+val structured_constant: formatter -> structured_constant -> unit
+val lambda: formatter -> lambda -> unit
diff --git a/bytecomp/symtable.ml b/bytecomp/symtable.ml
index 5d950c003..19f649d91 100644
--- a/bytecomp/symtable.ml
+++ b/bytecomp/symtable.ml
@@ -289,12 +289,12 @@ let filter_global_map p gmap =
 
 (* Error report *)
 
-open Formatmsg
+open Format
 
-let report_error = function
-    Undefined_global s ->
-      printf "Reference to undefined global `%s'" s
+let report_error ppf = function
+  | Undefined_global s ->
+      fprintf ppf "Reference to undefined global `%s'" s
   | Unavailable_primitive s ->
-      printf "The external function `%s' is not available" s
+      fprintf ppf "The external function `%s' is not available" s
   | Wrong_vm s ->
-      printf "Cannot find or execute the runtime system %s" s
+      fprintf ppf "Cannot find or execute the runtime system %s" s
diff --git a/bytecomp/symtable.mli b/bytecomp/symtable.mli
index 7fe203e9a..51601a958 100644
--- a/bytecomp/symtable.mli
+++ b/bytecomp/symtable.mli
@@ -50,4 +50,6 @@ type error =
 
 exception Error of error
 
-val report_error: error -> unit
+open Format
+
+val report_error: formatter -> error -> unit
diff --git a/bytecomp/translclass.ml b/bytecomp/translclass.ml
index 7e632ed5e..56b3af249 100644
--- a/bytecomp/translclass.ml
+++ b/bytecomp/translclass.ml
@@ -315,9 +315,8 @@ let class_stub =
 
 (* Error report *)
 
-open Formatmsg
+open Format
 
-let report_error = function
-  Illegal_class_expr ->
-    print_string
-      "This kind of class expression is not allowed"
+let report_error ppf = function
+  | Illegal_class_expr ->
+      fprintf ppf "This kind of class expression is not allowed"
diff --git a/bytecomp/translclass.mli b/bytecomp/translclass.mli
index 698302f3f..dd6d4ef6e 100644
--- a/bytecomp/translclass.mli
+++ b/bytecomp/translclass.mli
@@ -23,4 +23,6 @@ type error = Illegal_class_expr
 
 exception Error of Location.t * error
 
-val report_error: error -> unit
+open Format
+
+val report_error: formatter -> error -> unit
diff --git a/bytecomp/translcore.ml b/bytecomp/translcore.ml
index 1a21aef55..264d7e7d8 100644
--- a/bytecomp/translcore.ml
+++ b/bytecomp/translcore.ml
@@ -803,15 +803,15 @@ let transl_exception id path decl =
 
 (* Error report *)
 
-open Formatmsg
+open Format
 
-let report_error = function
-    Illegal_letrec_pat ->
-      print_string
+let report_error ppf = function
+  | Illegal_letrec_pat ->
+      fprintf ppf
         "Only variables are allowed as left-hand side of `let rec'"
   | Illegal_letrec_expr ->
-      print_string
+      fprintf ppf
         "This kind of expression is not allowed as right-hand side of `let rec'"
   | Free_super_var ->
-      print_string
+      fprintf ppf
         "Ancestor names can only be used to select inherited methods"
diff --git a/bytecomp/translcore.mli b/bytecomp/translcore.mli
index 46e2bb7f8..998189ec0 100644
--- a/bytecomp/translcore.mli
+++ b/bytecomp/translcore.mli
@@ -39,7 +39,9 @@ type error =
 
 exception Error of Location.t * error
 
-val report_error: error -> unit
+open Format
+
+val report_error: formatter -> error -> unit
 
 (* Forward declaration -- to be filled in by Translmod.transl_module *)
 val transl_module :
diff --git a/debugger/command_line.ml b/debugger/command_line.ml
index ce235e701..a50ee4ca5 100644
--- a/debugger/command_line.ml
+++ b/debugger/command_line.ml
@@ -15,7 +15,7 @@
 
 (************************ Reading and executing commands ***************)
 
-open Formatmsg
+open Format
 open Misc
 open Instruct
 open Unix
@@ -228,12 +228,10 @@ let instr_dir lexbuf =
         end
       end
     else
-      List.iter (function x -> add_path (expand_path x)) (List.rev new_directory);
-    open_box 2;
-    print_string "Directories :";
-    List.iter (function x -> print_space(); print_string x) !Config.load_path;
-    close_box();
-    print_newline ()
+      List.iter (function x -> add_path (expand_path x))
+                (List.rev new_directory);
+    let print_dirs ppf l = List.iter (function x -> fprintf ppf "@ %s" x) l in
+    fprintf ppf "@[<2>Directories :%a@]@." print_dirs !Config.load_path
 
 let instr_kill lexbuf =
   eol lexbuf;
@@ -326,26 +324,25 @@ let instr_goto lexbuf =
 let instr_quit _ =
   raise Exit
 
-let print_variable_list () =
-  print_endline "List of variables :";
-  List.iter (fun v -> print_string v.var_name; print_space()) !variable_list;
-  print_newline ()
+let print_variable_list ppf =
+  let pr_vars ppf = List.iter (fun v -> fprintf ppf "%s@ " v.var_name) in
+  fprintf ppf "List of variables :%a@." pr_vars !variable_list
 
-let print_info_list () =
-  print_endline "List of info commands :";
-  List.iter (fun i -> print_string i.info_name; print_space()) !info_list;
-  print_newline ()
+let print_info_list ppf =
+  let pr_infos ppf = List.iter (fun i -> fprintf ppf "%s@ " i.info_name)  in
+  print_endline "List of info commands :%a@." pr_infos !info_list
 
 let instr_complete lexbuf =
+  let ppf = Format.err_formatter in
   let rec print_list l = 
     try 
       eol lexbuf;
-      List.iter (function i -> print_string i; print_newline ()) l
+      List.iter (function i -> fprintf ppf "%s@." i) l
     with _ ->
       remove_file !user_channel
   and match_list lexbuf =
     match identifier_or_eol Lexer.lexeme lexbuf with
-      None ->
+    | None ->
         List.map (fun i -> i.instr_name) !instruction_list
     | Some x ->
         match matching_instructions x with
@@ -382,87 +379,77 @@ let instr_complete lexbuf =
   in
     print_list(match_list lexbuf)
 
-let instr_help lexbuf =
+let instr_help ppf lexbuf =
+  let pr_instrs ppf =
+      List.iter (fun i -> fprintf ppf "%s@ " i.instr_name) in
   match identifier_or_eol Lexer.lexeme lexbuf with
-    Some x ->
+  | Some x ->
       let print_help nm hlp =
         eol lexbuf;
-        print_string nm;
-        print_string " : ";
-        print_string hlp;
-        print_newline ()
-      in
-        begin match matching_instructions x with
-          [] ->
-            eol lexbuf;
-            print_string "No matching command.";
-            print_newline ()
-        | [ {instr_name = "set"} ] ->
-            find_variable
-              (fun v _ ->
-                 print_help ("set " ^ v.var_name) ("set " ^ v.var_help))
-              (fun () ->
-                 print_help "set" "set debugger variable.";
-                 print_variable_list ())
-              lexbuf
-        | [ {instr_name = "show"} ] ->
-            find_variable
-              (fun v _ ->
-                 print_help ("show " ^ v.var_name) ("show " ^ v.var_help))
-              (fun () ->
-                 print_help "show" "display debugger variable.";
-                 print_variable_list ())
-              lexbuf
-        | [ {instr_name = "info"} ] ->
-            find_info
-              (fun i _ -> print_help ("info " ^ i.info_name) i.info_help)
-              (fun () ->
-                 print_help "info" "display infos about the program being debugged.";
-                 print_info_list ())
-              lexbuf
-        | [i] ->
-            print_help i.instr_name i.instr_help
-        | l ->
-            eol lexbuf;
-            print_string ("Ambiguous command \"" ^ x ^ "\" : ");
-            List.iter
-              (fun i -> print_string i.instr_name; print_space())
-              l;
-            print_newline ()
-        end
+        fprintf ppf "%s : %s@." nm hlp in
+      begin match matching_instructions x with
+      | [] ->
+          eol lexbuf;
+          fprintf ppf "No matching command.@."
+      | [ {instr_name = "set"} ] ->
+          find_variable
+            (fun v _ ->
+               print_help ("set " ^ v.var_name) ("set " ^ v.var_help))
+            (fun () ->
+               print_help "set" "set debugger variable.";
+               print_variable_list ppf)
+            lexbuf
+      | [ {instr_name = "show"} ] ->
+          find_variable
+            (fun v _ ->
+               print_help ("show " ^ v.var_name) ("show " ^ v.var_help))
+            (fun () ->
+               print_help "show" "display debugger variable.";
+               print_variable_list ppf)
+            lexbuf
+      | [ {instr_name = "info"} ] ->
+          find_info
+            (fun i _ -> print_help ("info " ^ i.info_name) i.info_help)
+            (fun () ->
+               print_help "info"
+                 "display infos about the program being debugged.";
+               print_info_list ppf)
+            lexbuf
+      | [i] ->
+          print_help i.instr_name i.instr_help
+      | l ->
+          eol lexbuf;
+          fprintf ppf "Ambiguous command \"%s\" : @." x pr_instrs l
+      end
   | None ->
-      print_endline "List of commands :";
-      List.iter
-        (fun i -> print_string i.instr_name; print_space()) 
-        !instruction_list;
-      print_newline ()
+      print_endline "List of commands :%a@." pr_instrs !instruction_list
 
 (* Printing values *)
 
-let print_expr depth ev env expr =
+let print_expr depth ev env ppf expr =
   try
     let (v, ty) = Eval.expression ev env expr in
-    print_named_value depth expr v ty env
+    print_named_value depth expr v ty ppf env
   with Eval.Error msg ->
-    Eval.report_error msg;
+    Eval.report_error ppf msg;
     raise Toplevel
 
-let print_command depth lexbuf =
-  let exprs = expression_list_eol Lexer.lexeme lexbuf in
+let print_command depth ppf lexbuf =
+  let exprs = expression_list_eol Lexer.lexeme ppf lexbuf in
   ensure_loaded ();
   let env =
     try
       Envaux.env_of_event !selected_event
     with
       Envaux.Error msg ->
-        Envaux.report_error msg;
+        Envaux.report_error ppf msg;
         raise Toplevel
   in
-  List.iter (print_expr depth !selected_event env) exprs
+  List.iter (print_expr depth !selected_event env ppf) exprs
 
-let instr_print lexbuf = print_command !max_printer_depth lexbuf
+let instr_print ppf lexbuf = print_command !max_printer_depth ppf lexbuf
 
-let instr_display lexbuf = print_command 1 lexbuf
+let instr_display ppf lexbuf = print_command 1 ppf lexbuf
 
 (* Loading of command files *)
 
@@ -483,7 +470,7 @@ let instr_source lexbuf =
           (openfile (find_in_path !Config.load_path (expand_path file))
              [O_RDONLY] 0)
       with
-        Not_found -> prerr_endline "Source file not found."; raise Toplevel
+      | Not_found -> prerr_endline "Source file not found."; raise Toplevel
       | (Unix_error _) as x  -> Unix_tools.report_error x; raise Toplevel
     in
       try
diff --git a/debugger/debugcom.ml b/debugger/debugcom.ml
index 79b8fcfd8..3c56fd80a 100644
--- a/debugger/debugcom.ml
+++ b/debugger/debugcom.ml
@@ -171,7 +171,7 @@ module Remote_value =
     type t = Remote of string | Local of Obj.t
     
     let obj = function
-      Local obj -> Obj.obj obj
+    | Local obj -> Obj.obj obj
     | Remote v ->
         output_char !conn.io_out 'M';
         output_remote_value !conn.io_out v;
@@ -182,11 +182,11 @@ module Remote_value =
           raise Marshalling_error
 
     let is_block = function
-      Local obj -> Obj.is_block obj
+    | Local obj -> Obj.is_block obj
     | Remote v -> Obj.is_block (Array.unsafe_get (Obj.magic v : Obj.t array) 0)
 
     let tag = function
-      Local obj -> Obj.tag obj
+    | Local obj -> Obj.tag obj
     | Remote v ->
         output_char !conn.io_out 'H';
         output_remote_value !conn.io_out v;
@@ -195,7 +195,7 @@ module Remote_value =
         header land 0xFF
 
     let size = function
-      Local obj -> Obj.size obj
+    | Local obj -> Obj.size obj
     | Remote v ->
         output_char !conn.io_out 'H';
         output_remote_value !conn.io_out v;
@@ -205,7 +205,7 @@ module Remote_value =
 
     let field v n =
       match v with
-        Local obj -> Local(Obj.field obj n)
+      | Local obj -> Local(Obj.field obj n)
       | Remote v ->
           output_char !conn.io_out 'F';
           output_remote_value !conn.io_out v;
@@ -248,7 +248,7 @@ module Remote_value =
       Remote(input_remote_value !conn.io_in)
 
     let closure_code = function
-      Local obj -> assert false
+    | Local obj -> assert false
     | Remote v ->
         output_char !conn.io_out 'C';
         output_remote_value !conn.io_out v;
diff --git a/debugger/envaux.ml b/debugger/envaux.ml
index 352ea4909..ba8d6dff5 100644
--- a/debugger/envaux.ml
+++ b/debugger/envaux.ml
@@ -76,12 +76,8 @@ let env_of_event =
 
 (* Error report *)
 
-open Formatmsg
+open Format
 
-let report_error error =
-  open_box 0;
-  begin match error with
-    Module_not_found p ->
-      print_string "Cannot find module "; Printtyp.path p
-  end;
-  close_box(); print_newline()
+let report_error ppf = function
+  | Module_not_found p ->
+      fprintf ppf "@[Cannot find module %a@].@." Printtyp.path p
diff --git a/debugger/envaux.mli b/debugger/envaux.mli
index 7cd206643..8b122cc34 100644
--- a/debugger/envaux.mli
+++ b/debugger/envaux.mli
@@ -13,6 +13,8 @@
 
 (* $Id$ *)
 
+open Format
+
 (* Convert environment summaries to environments *)
 
 val env_of_event: Instruct.debug_event option -> Env.t
@@ -28,4 +30,4 @@ type error =
 
 exception Error of error
 
-val report_error: error -> unit
+val report_error: formatter -> error -> unit
diff --git a/debugger/eval.ml b/debugger/eval.ml
index dfa1557f5..5024cf5af 100644
--- a/debugger/eval.ml
+++ b/debugger/eval.ml
@@ -160,44 +160,48 @@ and find_label lbl env ty path tydesc pos = function
 
 (* Error report *)
 
-open Formatmsg
+open Format
 
-let report_error error =
-  open_box 0;
-  begin match error with
-    Unbound_identifier id ->
-      printf "Unbound identifier %s" (Ident.name id)
+let report_error ppf = function
+  | Unbound_identifier id ->
+      fprintf ppf "@[Unbound identifier %s@]@." (Ident.name id)
   | Not_initialized_yet path ->
-      print_string "The module path "; Printtyp.path path;
-      printf " is not yet initialized.@ ";
-      print_string "Please run program forward until its initialization code is executed."
+      fprintf ppf
+        "@[The module path %a is not yet initialized.@ \
+           Please run program forward@ \
+           until its initialization code is executed.@]@."
+      Printtyp.path path
   | Unbound_long_identifier lid ->
-      print_string "Unbound identifier "; Printtyp.longident lid
+      fprintf ppf "@[Unbound identifier %a@]@." Printtyp.longident lid
   | Unknown_name n ->
-      printf "Unknown value name $%i" n
+      fprintf ppf "@[Unknown value name $%i@]@." n
   | Tuple_index(ty, len, pos) ->
-      printf "Cannot extract field number %i from a %i" pos len;
-      print_string "-components tuple of type ";
-      Printtyp.reset (); Printtyp.mark_loops ty;
-      print_space(); Printtyp.type_expr ty
+      Printtyp.reset_and_mark_loops ty;
+      fprintf ppf
+        "@[Cannot extract field number %i from a %i-components \
+           tuple of type@ %a@]@."
+        pos len Printtyp.type_expr ty
   | Array_index(len, pos) ->
-      printf "Cannot extract element number %i from array of length %i" pos len
+      fprintf ppf
+        "@[Cannot extract element number %i from array of length %i@]@." pos len
   | List_index(len, pos) ->
-      printf "Cannot extract element number %i from list of length %i" pos len
+      fprintf ppf
+        "@[Cannot extract element number %i from list of length %i@]@." pos len
   | String_index(s, len, pos) ->
-      printf "Cannot extract character number %i" pos;
-      printf " from the following string of length %i:@ \"%s\""
-        len (String.escaped s)
+      fprintf ppf
+        "@[Cannot extract character number %i@ \
+           from the following string of length %i:@ \"%s\"@]@."
+        pos len (String.escaped s)
   | Wrong_item_type(ty, pos) ->
-      printf "Cannot extract item number %i from a value of type@ " pos;
-      Printtyp.type_expr ty
+      fprintf ppf
+        "@[Cannot extract item number %i from a value of type@ %a@]@."
+        pos Printtyp.type_expr ty
   | Wrong_label(ty, lbl) ->
-      printf "The record type@ "; Printtyp.type_expr ty;
-      printf "@ has no label named %s" lbl
+      fprintf ppf 
+        "@[The record type@ %a@ has no label named %s@]@."
+        Printtyp.type_expr ty lbl
   | Not_a_record ty ->
-      printf "The type@ "; Printtyp.type_expr ty;
-      print_string "@ is not a record type"
+      fprintf ppf
+        "@[The type@ %a@ is not a record type@]@." Printtyp.type_expr ty
   | No_result ->
-      print_string "No result available at current program event"
-  end;
-  close_box(); print_newline()
+      fprintf ppf "@[No result available at current program event@]@."
diff --git a/debugger/eval.mli b/debugger/eval.mli
index 6565ebc0e..b2a2998f1 100644
--- a/debugger/eval.mli
+++ b/debugger/eval.mli
@@ -15,13 +15,14 @@
 
 open Types
 open Parser_aux
+open Format
 
 val expression :
     Instruct.debug_event option -> Env.t -> expression ->
     Debugcom.Remote_value.t * type_expr
 
 type error =
-    Unbound_identifier of Ident.t
+  | Unbound_identifier of Ident.t
   | Not_initialized_yet of Path.t
   | Unbound_long_identifier of Longident.t
   | Unknown_name of int
@@ -36,4 +37,4 @@ type error =
 
 exception Error of error
 
-val report_error: error -> unit
+val report_error: formatter -> error -> unit
diff --git a/debugger/loadprinter.ml b/debugger/loadprinter.ml
index 4968ccdc0..e516380da 100644
--- a/debugger/loadprinter.ml
+++ b/debugger/loadprinter.ml
@@ -22,7 +22,7 @@ open Types
 (* Error report *)
 
 type error =
-    Load_failure of Dynlink.error
+  | Load_failure of Dynlink.error
   | Unbound_identifier of Longident.t
   | Unavailable_module of string * Longident.t
   | Wrong_type of Longident.t
@@ -39,7 +39,7 @@ let debugger_symtable = ref (None: Symtable.global_map option)
 let use_debugger_symtable fn arg =
   let old_symtable = Symtable.current_state() in
   begin match !debugger_symtable with
-    None ->
+  | None ->
       Symtable.init_toplevel();
       debugger_symtable := Some(Symtable.current_state())
   | Some st ->
@@ -56,21 +56,21 @@ let use_debugger_symtable fn arg =
 
 (* Load a .cmo or .cma file *)
 
-open Formatmsg
+open Format
 
-let rec loadfiles name =
+let rec loadfiles ppf name =
   try
     let filename = find_in_path !Config.load_path name in
     use_debugger_symtable Dynlink.loadfile filename;
-    printf "File %s loaded@." filename;
+    fprintf ppf "File %s loaded@." filename;
     true
   with
-    Dynlink.Error (Dynlink.Unavailable_unit unit) ->
+  | Dynlink.Error (Dynlink.Unavailable_unit unit) ->
       loadfiles (String.uncapitalize unit ^ ".cmo")
         &&
       loadfiles name
   | Not_found ->
-      printf "Cannot find file %s@." name;
+      fprintf ppf "Cannot find file %s@." name;
       false
   | Dynlink.Error e ->
       raise(Error(Load_failure e))
@@ -106,17 +106,17 @@ let find_printer_type lid =
     Ctype.generalize ty_arg;
     (ty_arg, path)
   with 
-    Not_found -> raise(Error(Unbound_identifier lid))
+  | Not_found -> raise(Error(Unbound_identifier lid))
   | Ctype.Unify _ -> raise(Error(Wrong_type lid))
     
-let install_printer lid =
+let install_printer ppf lid =
   let (ty_arg, path) = find_printer_type lid in
   let v =
     try
       use_debugger_symtable eval_path path
     with Symtable.Error(Symtable.Undefined_global s) ->
       raise(Error(Unavailable_module(s, lid))) in
-  Printval.install_printer path ty_arg (Obj.magic v : Obj.t -> unit)
+  Printval.install_printer path ty_arg ppf (Obj.magic v : Obj.t -> unit)
 
 let remove_printer lid =
   let (ty_arg, path) = find_printer_type lid in
@@ -127,27 +127,25 @@ let remove_printer lid =
 
 (* Error report *)
 
-open Formatmsg
+open Format
 
-let report_error error =
-  open_box 0;
-  begin match error with
-    Load_failure e ->
-      printf "Error during code loading: %s" (Dynlink.error_message e)
+let report_error ppf = function
+  | Load_failure e ->
+      fprintf ppf "@[Error during code loading: %s@]@."
+        (Dynlink.error_message e)
   | Unbound_identifier lid ->
-      print_string "Unbound identifier ";
+      fprintf ppf "@[Unbound identifier %a@]@."
       Printtyp.longident lid
   | Unavailable_module(md, lid) ->
-      printf "The debugger does not contain the code for@ ";
-      Printtyp.longident lid; printf ".@ ";
-      printf "Please load an implementation of %s first." md
+      fprintf ppf
+        "@[The debugger does not contain the code for@ %a.@ \
+           Please load an implementation of %s first.@]@."
+        Printtyp.longident lid md
   | Wrong_type lid ->
-      Printtyp.longident lid;
-      print_string " has the wrong type for a printing function."
+      fprintf ppf "@[%a has the wrong type for a printing function.@]@."
+      Printtyp.longident lid
   | No_active_printer lid ->
-      Printtyp.longident lid;
-      print_string " is not currently active as a printing function."
-  end;
-  close_box(); print_newline()
+      fprintf ppf "@[%a is not currently active as a printing function.@]@."
+      Printtyp.longident lid
 
       
diff --git a/debugger/printval.ml b/debugger/printval.ml
index fd620358e..cb8117a42 100644
--- a/debugger/printval.ml
+++ b/debugger/printval.ml
@@ -17,7 +17,7 @@
 
 open Misc
 open Obj
-open Formatmsg
+open Format
 open Parser_aux
 open Path
 open Types
@@ -41,23 +41,23 @@ let name_value v ty =
 let find_named_value name =
   Hashtbl.find named_values name
 
-let check_depth depth obj ty =
+let check_depth ppf depth obj ty =
   if depth <= 0 then begin
     let n = name_value obj ty in
-    print_char '$'; print_int n;
+    fprintf ppf "$%i" n;
     false
   end else true
 
 module Printer = Genprintval.Make(Debugcom.Remote_value)
 
-let install_printer path ty fn =
+let install_printer path ty ppf fn =
   Printer.install_printer path ty
     (function remote_val ->
        try
          fn (Obj.repr (Debugcom.Remote_value.obj remote_val))
        with
          Debugcom.Marshalling_error ->
-           print_string "<cannot fetch remote object>")
+           fprintf ppf "<cannot fetch remote object>")
 
 let remove_printer = Printer.remove_printer
 
@@ -66,23 +66,22 @@ let max_printer_steps = ref 300
 
 let print_exception = Printer.print_exception
 
-let print_value max_depth obj ty env =
+let print_value max_depth env obj (ppf : Format.formatter) ty =
   Printer.print_value !max_printer_steps max_depth
-    check_depth env obj ty
+   (check_depth ppf) env obj ppf ty
 
-let print_named_value max_depth exp obj ty env =
-  printf "@[<2>";
-  begin match exp with
-    E_ident lid ->
-      Printtyp.longident lid
+let print_named_value max_depth exp env obj ppf ty =
+  let print_value_name ppf = function
+  | E_ident lid ->
+      Printtyp.longident ppf lid
   | E_name n ->
-      print_char '$'; print_int n
+      fprintf ppf "$%i" n
   | _ ->
       let n = name_value obj ty in
-      print_char '$'; print_int n
-  end;
-  Printtyp.reset (); Printtyp.mark_loops ty;
-  printf " :@ "; Printtyp.type_expr ty;
-  printf "@ =@ ";
-  print_value max_depth obj ty env;
-  printf "@]@."
+      fprintf ppf "$%i" n in
+  Printtyp.reset_and_mark_loops ty;
+  fprintf ppf "@[<2>%a :@ %a@ =@ %a@]@."
+  print_value_name exp
+  Printtyp.type_expr ty
+  (print_value max_depth env obj) ty
+
diff --git a/debugger/printval.mli b/debugger/printval.mli
index 2df6779a1..f34a9e71d 100644
--- a/debugger/printval.mli
+++ b/debugger/printval.mli
@@ -13,17 +13,20 @@
 
 (* $Id$ *)
 
+open Format
+
 val max_printer_depth : int ref
 val max_printer_steps : int ref
 
-val print_exception: Debugcom.Remote_value.t -> unit
+val print_exception: formatter -> Debugcom.Remote_value.t -> unit
 val print_named_value :
-  int -> Parser_aux.expression ->
-    Debugcom.Remote_value.t -> Types.type_expr -> Env.t ->
+  int -> Parser_aux.expression -> Env.t ->
+    Debugcom.Remote_value.t -> formatter -> Types.type_expr ->
     unit
 
 val reset_named_values : unit -> unit
 val find_named_value : int -> Debugcom.Remote_value.t * Types.type_expr
 
-val install_printer : Path.t -> Types.type_expr -> (Obj.t -> unit) -> unit
+val install_printer :
+  Path.t -> Types.type_expr -> formatter -> (Obj.t -> unit) -> unit
 val remove_printer : Path.t -> unit
diff --git a/debugger/show_information.ml b/debugger/show_information.ml
index 65a6b7649..b2d89eddf 100644
--- a/debugger/show_information.ml
+++ b/debugger/show_information.ml
@@ -14,7 +14,7 @@
 (* $Id$ *)
 
 open Instruct
-open Formatmsg
+open Format
 open Primitives
 open Debugcom
 open Checkpoints
@@ -25,44 +25,41 @@ open Show_source
 open Breakpoints
 
 (* Display information about the current event. *)
-let show_current_event () =
-  print_string "Time : "; print_int (current_time ());
+let show_current_event ppf =
+  fprintf ppf "Time : %i" (current_time ());
   (match current_pc () with
-     Some pc ->
-       print_string " - pc : "; print_int pc
+   | Some pc ->
+       fprintf ppf " - pc : %i" pc
    | _ -> ());
   update_current_event ();
   reset_frame ();
   match current_report ()  with
-    None ->
-      print_newline ();
-      print_string "Beginning of program."; print_newline ();
+  | None ->
+      fprintf ppf "@.Beginning of program.@.";
       show_no_point ()
   | Some {rep_type = (Event | Breakpoint); rep_program_pointer = pc} -> 
      let (mdle, point) = current_point () in
-        print_string (" - module " ^ mdle);
-        print_newline ();
+        fprintf ppf " - module %s@." mdle;
         (match breakpoints_at_pc pc with
-           [] ->
+         | [] ->
              ()
          | [breakpoint] ->
-             print_string "Breakpoint : "; print_int breakpoint;
-             print_newline ()
+             fprintf ppf "Breakpoint : %i@." breakpoint
          | breakpoints ->
-             print_string "Breakpoints : ";
-             List.iter
-               (function x -> print_int x; print_string " ")
-               (Sort.list (<) breakpoints);
-             print_newline ());
+             fprintf ppf "Breakpoints : %a@."
+             (fun ppf l ->
+               List.iter
+                (function x -> fprintf ppf "%i " x) l)
+             (Sort.list (<) breakpoints));
         show_point mdle point (current_event_is_before ()) true
   | Some {rep_type = Exited} ->
-      print_newline (); print_string "Program exit."; print_newline ();
+      fprintf ppf "@.Program exit.@.";
       show_no_point ()
   | Some {rep_type = Uncaught_exc} ->
-      printf "@.Program end.@.";
-      printf "@[Uncaught exception:@ ";
+      fprintf ppf
+        "@.Program end.@.\
+         @[Uncaught exception:@ %a@]@."
       Printval.print_exception (Debugcom.Remote_value.accu ());
-      printf"@]@.";
       show_no_point ()
   | Some {rep_type = Trap_barrier} ->
                                         (* Trap_barrier not visible outside *)
@@ -71,27 +68,27 @@ let show_current_event () =
 
 (* Display short information about one frame. *)
 
-let show_one_frame framenum event =
-  printf "#%i  Pc : %i  %s char %i@."
+let show_one_frame framenum ppf event =
+  fprintf ppf "#%i  Pc : %i  %s char %i@."
          framenum event.ev_pos event.ev_module event.ev_char
 
 (* Display information about the current frame. *)
 (* --- `select frame' must have succeded before calling this function. *)
-let show_current_frame selected =
+let show_current_frame ppf selected =
   match !selected_event with
-    None ->
-      printf "@.No frame selected.@."
+  | None ->
+      fprintf ppf "@.No frame selected.@."
   | Some sel_ev ->
-      show_one_frame !current_frame sel_ev;
+      show_one_frame !current_frame ppf sel_ev;
       begin match breakpoints_at_pc sel_ev.ev_pos with
-        [] ->
-          ()
+      | [] -> ()
       | [breakpoint] ->
-          printf "Breakpoint : %i@." breakpoint
+          fprintf ppf "Breakpoint : %i@." breakpoint
       | breakpoints ->
-          printf "Breakpoints : ";
-          List.iter (function x -> printf "%i " x) (Sort.list (<) breakpoints);
-          print_newline ()
+          fprintf ppf "Breakpoints : %a@."
+          (fun ppf l ->
+            List.iter (function x -> fprintf ppf "%i " x) l)
+          (Sort.list (<) breakpoints);
       end;
       show_point sel_ev.ev_module sel_ev.ev_char
                  (selected_event_is_before ()) selected
diff --git a/debugger/show_information.mli b/debugger/show_information.mli
index 68d099da2..3069f9332 100644
--- a/debugger/show_information.mli
+++ b/debugger/show_information.mli
@@ -13,12 +13,14 @@
 
 (* $Id$ *)
 
+open Format;;
+
 (* Display information about the current event. *)
-val show_current_event : unit -> unit;;
+val show_current_event : formatter -> unit;;
 
 (* Display information about the current frame. *)
 (* --- `select frame' must have succeded before calling this function. *)
-val show_current_frame : bool -> unit;;
+val show_current_frame : formatter -> bool -> unit;;
 
 (* Display short information about one frame. *)
-val show_one_frame : int -> Instruct.debug_event -> unit
+val show_one_frame : int -> formatter -> Instruct.debug_event -> unit
diff --git a/debugger/unix_tools.ml b/debugger/unix_tools.ml
index ec4f4079c..9de33ca5b 100644
--- a/debugger/unix_tools.ml
+++ b/debugger/unix_tools.ml
@@ -40,7 +40,7 @@ let convert_address address =
 
 (*** Report an unix error. ***)
 let report_error = function
-    Unix_error (err, fun_name, arg) ->
+  | Unix_error (err, fun_name, arg) ->
      prerr_string "Unix error : '";
      prerr_string fun_name;
      prerr_string "' failed";
diff --git a/driver/compile.ml b/driver/compile.ml
index 85ef71d11..d4a555df3 100644
--- a/driver/compile.ml
+++ b/driver/compile.ml
@@ -16,7 +16,7 @@
 
 open Misc
 open Config
-open Formatmsg
+open Format
 open Typedtree
 
 (* Initialize the search path.
@@ -98,27 +98,27 @@ let parse_file inputfile parse_fun ast_magic =
 
 (* Compile a .mli file *)
 
-let interface sourcefile =
+let interface ppf sourcefile =
   init_path();
   let prefixname = Filename.chop_extension sourcefile in
   let modulename = String.capitalize(Filename.basename prefixname) in
   let inputfile = preprocess sourcefile (prefixname ^ ".ppi") in
   let ast = parse_file inputfile Parse.interface ast_intf_magic_number in
-  if !Clflags.dump_parsetree then (Printast.interface ast; print_newline ());
+  if !Clflags.dump_parsetree then fprintf ppf "%a@." Printast.interface ast;
   let sg = Typemod.transl_signature (initial_env()) ast in
-  if !Clflags.print_types then (Printtyp.signature sg; print_newline());
+  if !Clflags.print_types then fprintf ppf "%a@." Printtyp.signature sg;
   Env.save_signature sg modulename (prefixname ^ ".cmi");
   remove_preprocessed inputfile
 
 (* Compile a .ml file *)
 
-let print_if flag printer arg =
-  if !flag then begin printer arg; print_newline() end;
+let print_if ppf flag printer arg =
+  if !flag then fprintf ppf "%a@." printer arg;
   arg
 
 let (++) x f = f x
 
-let implementation sourcefile =
+let implementation ppf sourcefile =
   init_path();
   let prefixname = Filename.chop_extension sourcefile in
   let modulename = String.capitalize(Filename.basename prefixname) in
@@ -128,14 +128,14 @@ let implementation sourcefile =
   let env = initial_env() in
   try
     parse_file inputfile Parse.implementation ast_impl_magic_number
-    ++ print_if Clflags.dump_parsetree Printast.implementation
+    ++ print_if ppf Clflags.dump_parsetree Printast.implementation
     ++ Typemod.type_implementation sourcefile prefixname modulename env
     ++ Translmod.transl_implementation modulename
-    ++ print_if Clflags.dump_rawlambda Printlambda.lambda
+    ++ print_if ppf Clflags.dump_rawlambda Printlambda.lambda
     ++ Simplif.simplify_lambda
-    ++ print_if Clflags.dump_lambda Printlambda.lambda
+    ++ print_if ppf Clflags.dump_lambda Printlambda.lambda
     ++ Bytegen.compile_implementation modulename
-    ++ print_if Clflags.dump_instr Printinstr.instrlist
+    ++ print_if ppf Clflags.dump_instr Printinstr.instrlist
     ++ Emitcode.to_file oc modulename;
     remove_preprocessed inputfile;
     close_out oc
diff --git a/driver/compile.mli b/driver/compile.mli
index 42f1c0798..2271d103e 100644
--- a/driver/compile.mli
+++ b/driver/compile.mli
@@ -14,8 +14,10 @@
 
 (* Compile a .ml or .mli file *)
 
-val interface: string -> unit
-val implementation: string -> unit
+open Format
+
+val interface: formatter -> string -> unit
+val implementation: formatter -> string -> unit
 val c_file: string -> unit
 
 val initial_env: unit -> Env.t
diff --git a/driver/errors.ml b/driver/errors.ml
index ebb3dcecc..8f877a45f 100644
--- a/driver/errors.ml
+++ b/driver/errors.ml
@@ -14,48 +14,47 @@
 
 (* Error report *)
 
-open Formatmsg
+open Format
 open Location
 
 (* Report an error *)
 
-let report_error exn =
-  open_box 0;
-  begin match exn with
-    Lexer.Error(err, start, stop) ->
-      Location.print {loc_start = start; loc_end = stop; loc_ghost = false};
-      Lexer.report_error err
+let report_error ppf exn =
+  let report ppf = function
+  | Lexer.Error(err, start, stop) ->
+      Location.print ppf {loc_start = start; loc_end = stop; loc_ghost = false};
+      Lexer.report_error ppf err
   | Syntaxerr.Error err ->
-      Syntaxerr.report_error err
+      Syntaxerr.report_error ppf err
   | Env.Error err ->
-      Env.report_error err
-  | Ctype.Tags(l, l') ->
-      printf "In this program,@ variant constructors@ `%s and `%s@ have same hash value." l l'
+      Env.report_error ppf err
+  | Ctype.Tags(l, l') -> fprintf ppf
+      "In this program,@ variant constructors@ `%s and `%s@ \
+       have the same hash value." l l'
   | Typecore.Error(loc, err) ->
-      Location.print loc; Typecore.report_error err
+      Location.print ppf loc; Typecore.report_error ppf err
   | Typetexp.Error(loc, err) ->
-      Location.print loc; Typetexp.report_error err
+      Location.print ppf loc; Typetexp.report_error ppf err
   | Typedecl.Error(loc, err) ->
-      Location.print loc; Typedecl.report_error err
+      Location.print ppf loc; Typedecl.report_error ppf err
   | Includemod.Error err ->
-      Includemod.report_error err
+      Includemod.report_error ppf err
   | Typemod.Error(loc, err) ->
-      Location.print loc; Typemod.report_error err
+      Location.print ppf loc; Typemod.report_error ppf err
   | Translcore.Error(loc, err) ->
-      Location.print loc; Translcore.report_error err
+      Location.print ppf loc; Translcore.report_error ppf err
   | Symtable.Error code ->
-      Symtable.report_error code
+      Symtable.report_error ppf code
   | Bytelink.Error code ->
-      Bytelink.report_error code
+      Bytelink.report_error ppf code
   | Bytelibrarian.Error code ->
-      Bytelibrarian.report_error code
+      Bytelibrarian.report_error ppf code
   | Sys_error msg ->
-      printf "I/O error: %s" msg
+      fprintf ppf "I/O error: %s" msg
   | Typeclass.Error(loc, err) ->
-      Location.print loc; Typeclass.report_error err
+      Location.print ppf loc; Typeclass.report_error ppf err
   | Translclass.Error(loc, err) ->
-      Location.print loc; Translclass.report_error err
-  | x ->
-      close_box(); raise x
-  end;
-  close_box(); print_newline()
+      Location.print ppf loc; Translclass.report_error ppf err
+  | x -> close_box(); raise x in
+
+  fprintf ppf "@[%a@]@." report exn
diff --git a/driver/errors.mli b/driver/errors.mli
index be55c0e12..ac203a53e 100644
--- a/driver/errors.mli
+++ b/driver/errors.mli
@@ -13,5 +13,6 @@
 (* $Id$ *)
 
 (* Error report *)
+open Format
 
-val report_error: exn -> unit
+val report_error: formatter -> exn -> unit
diff --git a/driver/main.ml b/driver/main.ml
index 194371ca0..43a330da3 100644
--- a/driver/main.ml
+++ b/driver/main.ml
@@ -15,21 +15,21 @@
 open Config
 open Clflags
 
-let process_interface_file name =
-  Compile.interface name
+let process_interface_file ppf name =
+  Compile.interface ppf name
 
-let process_implementation_file name =
-  Compile.implementation name;
+let process_implementation_file ppf name =
+  Compile.implementation ppf name;
   objfiles := (Filename.chop_extension name ^ ".cmo") :: !objfiles
 
-let process_file name =
+let process_file ppf name =
   if Filename.check_suffix name ".ml"
   or Filename.check_suffix name ".mlt" then begin
-    Compile.implementation name;
+    Compile.implementation ppf name;
     objfiles := (Filename.chop_extension name ^ ".cmo") :: !objfiles
   end
   else if Filename.check_suffix name !Config.interface_suffix then
-    Compile.interface name
+    Compile.interface ppf name
   else if Filename.check_suffix name ".cmo"
        or Filename.check_suffix name ".cma" then
     objfiles := name :: !objfiles
@@ -56,6 +56,11 @@ let print_version_number () =
 
 let usage = "Usage: ocamlc <options> <files>\nOptions are:"
 
+(* Error messages to standard error formatter *)
+let anonymous = process_file Format.err_formatter;;
+let impl = process_implementation_file Format.err_formatter;;
+let intf = process_interface_file Format.err_formatter;;
+
 module Options = Main_args.Make_options (struct
   let set r () = r := true
   let unset r () = r := false
@@ -68,8 +73,8 @@ module Options = Main_args.Make_options (struct
   let _g = set debug
   let _i = set print_types
   let _I s = include_dirs := s :: !include_dirs
-  let _impl = process_implementation_file
-  let _intf = process_interface_file
+  let _impl = impl
+  let _intf = intf
   let _intf_suffix s = Config.interface_suffix := s
   let _linkall = set link_everything
   let _make_runtime () =
@@ -92,24 +97,24 @@ module Options = Main_args.Make_options (struct
   let _drawlambda = set dump_rawlambda
   let _dlambda = set dump_lambda
   let _dinstr = set dump_instr
-  let anonymous = process_file
+  let anonymous = anonymous
 end)
 
 let main () =
-  Formatmsg.set_output Format.err_formatter;
+(* A supprimer   Formatmsg.set_output Format.err_formatter;*)
   try
-    Arg.parse Options.list process_file usage;
+    Arg.parse Options.list anonymous usage;
     if !make_archive then begin
       Compile.init_path();
       Bytelibrarian.create_archive (List.rev !objfiles) !archive_name
     end
-    else if not !compile_only & !objfiles <> [] then begin
+    else if not !compile_only && !objfiles <> [] then begin
       Compile.init_path();
       Bytelink.link (List.rev !objfiles)
     end;
     exit 0
   with x ->
-    Errors.report_error x;
+    Errors.report_error Format.err_formatter x;
     exit 2
 
 let _ = Printexc.catch main ()
diff --git a/otherlibs/labltk/browser/searchpos.ml b/otherlibs/labltk/browser/searchpos.ml
index 5aa58e814..321deecee 100644
--- a/otherlibs/labltk/browser/searchpos.ml
+++ b/otherlibs/labltk/browser/searchpos.ml
@@ -326,7 +326,7 @@ let rec view_signature ?:title ?:path ?(:env = !start_env) sign =
       tl, tw, finish
   in
   Format.set_max_boxes 100;
-  Printtyp.signature sign;
+  Printtyp.signature Format.std_formatter sign;
   finish ();
   Lexical.init_tags tw;
   Lexical.tag tw;
@@ -466,10 +466,12 @@ and view_decl_menu lid :kind :env :parent =
     if kind = `Type then
       Printtyp.type_declaration
         (ident_of_path path default:"t")
+        Format.std_formatter
         (find_type path env)
     else
       Printtyp.modtype_declaration
         (ident_of_path path default:"S")
+        Format.std_formatter
         (find_modtype path env);
     Format.close_box (); Format.print_flush ();
     Format.set_formatter_output_functions out:fo flush:ff;
@@ -560,7 +562,7 @@ let view_type_menu kind :env :parent =
       Format.open_hbox ();
       Printtyp.reset ();
       Printtyp.mark_loops ty;
-      Printtyp.type_expr ty;
+      Printtyp.type_expr Format.std_formatter ty;
       Format.close_box (); Format.print_flush ();
       Format.set_formatter_output_functions out:fo flush:ff;
       Format.set_margin margin;
diff --git a/otherlibs/labltk/browser/typecheck.ml b/otherlibs/labltk/browser/typecheck.ml
index ee49c7743..c3666c8da 100644
--- a/otherlibs/labltk/browser/typecheck.ml
+++ b/otherlibs/labltk/browser/typecheck.ml
@@ -61,30 +61,33 @@ let f txt =
       error_messages := et :: !error_messages;
       let s, e = match exn with
         Lexer.Error (err, s, e) ->
-          Lexer.report_error err; s,e
+          Lexer.report_error Format.err_formatter err; s,e
       | Syntaxerr.Error err ->
-          Syntaxerr.report_error err;
+          Syntaxerr.report_error Format.err_formatter err;
           let l =
             match err with
               Syntaxerr.Unclosed(l,_,_,_) -> l
             | Syntaxerr.Other l -> l
           in l.loc_start, l.loc_end
       | Typecore.Error (l,err) ->
-          Typecore.report_error err; l.loc_start, l.loc_end
+          Typecore.report_error Format.err_formatter err;
+          l.loc_start, l.loc_end
       | Typeclass.Error (l,err) ->
-          Typeclass.report_error err; l.loc_start, l.loc_end
+          Typeclass.report_error Format.err_formatter err;
+          l.loc_start, l.loc_end
       | Typedecl.Error (l, err) ->
-          Typedecl.report_error err; l.loc_start, l.loc_end
+          Typedecl.report_error Format.err_formatter err;
+          l.loc_start, l.loc_end
       | Typemod.Error (l,err) ->
-          Typemod.report_error err; l.loc_start, l.loc_end
+          Typemod.report_error Format.err_formatter err; l.loc_start, l.loc_end
       | Typetexp.Error (l,err) ->
-          Typetexp.report_error err; l.loc_start, l.loc_end
+          Typetexp.report_error Format.err_formatter err; l.loc_start, l.loc_end
       | Includemod.Error errl ->
-          Includemod.report_error errl; 0, 0
+          Includemod.report_error Format.err_formatter errl; 0, 0
       | Env.Error err ->
-          Env.report_error err; 0, 0
+          Env.report_error Format.err_formatter err; 0, 0
       | Ctype.Tags(l, l') ->
-          Format.printf "In this program,@ variant constructors@ `%s and `%s@ have same hash value." l l'; 0, 0
+          Format.printf "In this program,@ variant constructors@ `%s and `%s@ have same hash value.@." l l'; 0, 0
       | _ -> assert false
       in
       end_message ();
diff --git a/otherlibs/labltk/browser/viewer.ml b/otherlibs/labltk/browser/viewer.ml
index bebd908c7..e5943f096 100644
--- a/otherlibs/labltk/browser/viewer.ml
+++ b/otherlibs/labltk/browser/viewer.ml
@@ -212,7 +212,7 @@ let view_defined modlid :env =
   with Not_found -> ()
   | Env.Error err ->
       let tl, tw, finish = Jg_message.formatted title:"Error!" () in
-      Env.report_error err;
+      Env.report_error Format.std_formatter err;
       finish ()
 
 let close_all_views () =
diff --git a/parsing/lexer.mli b/parsing/lexer.mli
index 1c9e81524..51bdd4389 100644
--- a/parsing/lexer.mli
+++ b/parsing/lexer.mli
@@ -25,4 +25,6 @@ type error =
 
 exception Error of error * int * int
 
-val report_error: error -> unit
+open Format
+
+val report_error: formatter -> error -> unit
diff --git a/parsing/lexer.mll b/parsing/lexer.mll
index 205e0f2c5..11bcb483f 100644
--- a/parsing/lexer.mll
+++ b/parsing/lexer.mll
@@ -148,17 +148,17 @@ let comment_start_pos = ref [];;
 
 (* Error report *)
 
-open Formatmsg
+open Format
 
-let report_error = function
-    Illegal_character c ->
-      printf "Illegal character (%s)" (Char.escaped c)
+let report_error ppf = function
+  | Illegal_character c ->
+      fprintf ppf "Illegal character (%s)" (Char.escaped c)
   | Unterminated_comment ->
-      print_string "Comment not terminated"
+      fprintf ppf "Comment not terminated"
   | Unterminated_string ->
-      print_string "String literal not terminated"
+      fprintf ppf "String literal not terminated"
   | Unterminated_string_in_comment ->
-      print_string "This comment contains an unterminated string literal"
+      fprintf ppf "This comment contains an unterminated string literal"
 ;;
 
 }
@@ -229,7 +229,7 @@ rule token = parse
                     Location.loc_ghost = false }
         and warn = Warnings.Comment "the start of a comment"
         in
-        Location.print_warning loc warn;
+        Location.prerr_warning loc warn;
         comment_start_pos := [Lexing.lexeme_start lexbuf];
         comment lexbuf;
         token lexbuf
@@ -240,7 +240,7 @@ rule token = parse
                     Location.loc_ghost = false }
         and warn = Warnings.Comment "not the end of a comment"
         in
-        Location.print_warning loc warn;
+        Location.prerr_warning loc warn;
         lexbuf.Lexing.lex_curr_pos <- lexbuf.Lexing.lex_curr_pos - 1;
         STAR
       }
diff --git a/parsing/location.ml b/parsing/location.ml
index 6e0b5099e..e9b64c5be 100644
--- a/parsing/location.ml
+++ b/parsing/location.ml
@@ -91,7 +91,7 @@ let rec highlight_locations loc1 loc2 =
 
 (* Print the location in some way or another *)
 
-open Formatmsg
+open Format
 
 let reset () =
   num_loc_lines := 0
@@ -101,30 +101,28 @@ let (msg_file, msg_line, msg_chars, msg_to, msg_colon, msg_head) =
   | "MacOS" -> ("File \"", "\"; line ", "; characters ", " to ", "", "### ")
   | _ -> ("File \"", "\", line ", ", characters ", "-", ":", "")
 
-let print loc =
+let print ppf loc =
   if String.length !input_name = 0 then
     if highlight_locations loc none then () else
-      printf "Characters %i-%i:@." loc.loc_start loc.loc_end
+      fprintf ppf "Characters %i-%i:@." loc.loc_start loc.loc_end
   else begin
     let (filename, linenum, linebeg) =
             Linenum.for_position !input_name loc.loc_start in
-    print_string msg_file; print_string filename;
-    print_string msg_line; print_int linenum;
-    print_string msg_chars; print_int (loc.loc_start - linebeg);
-    print_string msg_to; print_int (loc.loc_end - linebeg);
-    print_string msg_colon;
-    force_newline();
-    print_string msg_head;
+    fprintf ppf "%s%s%s%i" msg_file filename msg_line linenum;
+    fprintf ppf "%s%i" msg_chars (loc.loc_start - linebeg);
+    fprintf ppf "%s%i%s@.%s"
+     msg_to (loc.loc_end - linebeg) msg_colon msg_head;
   end
 
-let print_warning loc w =
+let print_warning loc ppf w =
  if Warnings.is_active w then begin
-  print loc;
-  printf "Warning: %s@." (Warnings.message w);
+  fprintf ppf "%aWarning: %s@." print loc (Warnings.message w);
   incr num_loc_lines;
  end
 ;;
 
+let prerr_warning loc w = print_warning loc err_formatter w;;
+
 let echo_eof () =
   print_newline ();
   incr num_loc_lines
diff --git a/parsing/location.mli b/parsing/location.mli
index cd9ae7bcc..46330e3c8 100644
--- a/parsing/location.mli
+++ b/parsing/location.mli
@@ -13,6 +13,7 @@
 (* $Id$ *)
 
 (* Source code locations, used in parsetree *)
+open Format
 
 type t =
   { loc_start: int; loc_end: int; loc_ghost: bool }
@@ -25,8 +26,9 @@ val rhs_loc: int -> t
 val input_name: string ref
 val input_lexbuf: Lexing.lexbuf option ref
 
-val print: t -> unit
-val print_warning: t -> Warnings.t -> unit
+val print: formatter -> t -> unit
+val print_warning: t -> formatter -> Warnings.t -> unit
+val prerr_warning: t -> Warnings.t -> unit
 val echo_eof: unit -> unit
 val reset: unit -> unit
 
diff --git a/parsing/printast.ml b/parsing/printast.ml
index ca7bbd687..1cf9d780f 100644
--- a/parsing/printast.ml
+++ b/parsing/printast.ml
@@ -74,550 +74,557 @@ let fmt_private_flag f x =
   | Private -> Format.fprintf f "Private";
 ;;
 
-let line i s (*...*) =
-  printf "%s" (String.make (2*i) ' ');
-  printf s (*...*)
+open Format
+let line i f s (*...*) =
+  fprintf f "%s" (String.make (2*i) ' ');
+  fprintf f s (*...*)
 ;;
 
-let list i f l = List.iter (f i) l;;
+let list i f ppf l = List.iter (f i ppf) l;;
 
-let option i f x =
+let option i f ppf x =
   match x with
-  | None -> line i "None\n";
+  | None -> line i ppf "None\n";
   | Some x ->
-      line i "Some\n";
-      f (i+1) x;
+      line i ppf "Some\n";
+      f (i+1) ppf x;
 ;;
 
-let longident i li = line i "%a\n" fmt_longident li;;
-let string i s = line i "\"%s\"\n" s;;
-let bool i x = line i "%s\n" (string_of_bool x);;
-let label i x = line i "label=\"%s\"\n" x;;
+let longident i ppf li = line i ppf "%a\n" fmt_longident li;;
+let string i ppf s = line i ppf "\"%s\"\n" s;;
+let bool i ppf x = line i ppf "%s\n" (string_of_bool x);;
+let label i ppf x = line i ppf "label=\"%s\"\n" x;;
 
-let rec core_type i x =
-  line i "core_type %a\n" fmt_location x.ptyp_loc;
+let rec core_type i ppf x =
+  line i ppf "core_type %a\n" fmt_location x.ptyp_loc;
   let i = i+1 in
   match x.ptyp_desc with
-  | Ptyp_any -> line i "Ptyp_any\n";
-  | Ptyp_var (s) -> line i "Ptyp_var %s\n" s;
+  | Ptyp_any -> line i ppf "Ptyp_any\n";
+  | Ptyp_var (s) -> line i ppf "Ptyp_var %s\n" s;
   | Ptyp_arrow (l, ct1, ct2) ->
-      line i "Ptyp_arrow\n";
-      string i l;
-      core_type i ct1;
-      core_type i ct2;
+      line i ppf "Ptyp_arrow\n";
+      string i ppf l;
+      core_type i ppf ct1;
+      core_type i ppf ct2;
   | Ptyp_tuple l ->
-      line i "Ptyp_tuple\n";
-      list i core_type l;
+      line i ppf "Ptyp_tuple\n";
+      list i core_type ppf l;
   | Ptyp_constr (li, l) ->
-      line i "Ptyp_constr %a\n" fmt_longident li;
-      list i core_type l;
+      line i ppf "Ptyp_constr %a\n" fmt_longident li;
+      list i core_type ppf l;
   | Ptyp_variant (l, closed, low) ->
-      line i "Ptyp_variant closed=%s\n" (string_of_bool closed);
-      list i label_x_bool_x_core_type_list l;
-      list i string low
+      line i ppf "Ptyp_variant closed=%s\n" (string_of_bool closed);
+      list i label_x_bool_x_core_type_list ppf l;
+      list i string ppf low
   | Ptyp_object (l) ->
-      line i "Ptyp_object\n";
-      list i core_field_type l;
+      line i ppf "Ptyp_object\n";
+      list i core_field_type ppf l;
   | Ptyp_class (li, l, low) ->
-      line i "Ptyp_class %a\n" fmt_longident li;
-      list i core_type l;
-      list i string low
+      line i ppf "Ptyp_class %a\n" fmt_longident li;
+      list i core_type ppf l;
+      list i string ppf low
   | Ptyp_alias (ct, s) ->
-      line i "Ptyp_alias \"%s\"\n" s;
-      core_type i ct;
+      line i ppf "Ptyp_alias \"%s\"\n" s;
+      core_type i ppf ct;
 
-and core_field_type i x =
-  line i "core_field_type %a\n" fmt_location x.pfield_loc;
+and core_field_type i ppf x =
+  line i ppf "core_field_type %a\n" fmt_location x.pfield_loc;
   let i = i+1 in
   match x.pfield_desc with
   | Pfield (s, ct) ->
-      line i "Pfield \"%s\"\n" s;
-      core_type i ct;
-  | Pfield_var -> line i "Pfield_var\n";
+      line i ppf "Pfield \"%s\"\n" s;
+      core_type i ppf ct;
+  | Pfield_var -> line i ppf "Pfield_var\n";
 
-and pattern i x =
-  line i "pattern %a\n" fmt_location x.ppat_loc;
+and pattern i ppf x =
+  line i ppf "pattern %a\n" fmt_location x.ppat_loc;
   let i = i+1 in
   match x.ppat_desc with
-  | Ppat_any -> line i "Ppat_any\n";
-  | Ppat_var (s) -> line i "Ppat_var \"%s\"\n" s;
+  | Ppat_any -> line i ppf "Ppat_any\n";
+  | Ppat_var (s) -> line i ppf "Ppat_var \"%s\"\n" s;
   | Ppat_alias (p, s) ->
-      line i "Ppat_alias \"%s\"\n" s;
-      pattern i p;
-  | Ppat_constant (c) -> line i "Ppat_constant %a\n" fmt_constant c;
+      line i ppf "Ppat_alias \"%s\"\n" s;
+      pattern i ppf p;
+  | Ppat_constant (c) -> line i ppf "Ppat_constant %a\n" fmt_constant c;
   | Ppat_tuple (l) ->
-      line i "Ppat_tuple\n";
-      list i pattern l;
+      line i ppf "Ppat_tuple\n";
+      list i pattern ppf l;
   | Ppat_construct (li, po, b) ->
-      line i "Ppat_construct %a\n" fmt_longident li;
-      option i pattern po;
-      bool i b;
+      line i ppf "Ppat_construct %a\n" fmt_longident li;
+      option i pattern ppf po;
+      bool i ppf b;
   | Ppat_variant (l, po) ->
-      line i "Ppat_variant `%s\n" l;
-      option i pattern po;
+      line i ppf "Ppat_variant `%s\n" l;
+      option i pattern ppf po;
   | Ppat_record (l) ->
-      line i "Ppat_record\n";
-      list i longident_x_pattern l;
+      line i ppf "Ppat_record\n";
+      list i longident_x_pattern ppf l;
   | Ppat_array (l) ->
-      line i "Ppat_array\n";
-      list i pattern l;
+      line i ppf "Ppat_array\n";
+      list i pattern ppf l;
   | Ppat_or (p1, p2) ->
-      line i "Ppat_or\n";
-      pattern i p1;
-      pattern i p2;
+      line i ppf "Ppat_or\n";
+      pattern i ppf p1;
+      pattern i ppf p2;
   | Ppat_constraint (p, ct) ->
-      line i "Ppat_constraint";
-      pattern i p;
-      core_type i ct;
+      line i ppf "Ppat_constraint";
+      pattern i ppf p;
+      core_type i ppf ct;
   | Ppat_type li ->
-      line i "PPat_type";
-      longident i li
+      line i ppf "PPat_type";
+      longident i ppf li
 
-and expression i x =
-  line i "expression %a\n" fmt_location x.pexp_loc;
+and expression i ppf x =
+  line i ppf "expression %a\n" fmt_location x.pexp_loc;
   let i = i+1 in
   match x.pexp_desc with
-  | Pexp_ident (li) -> line i "Pexp_ident %a\n" fmt_longident li;
-  | Pexp_constant (c) -> line i "Pexp_constant %a\n" fmt_constant c;
+  | Pexp_ident (li) -> line i ppf "Pexp_ident %a\n" fmt_longident li;
+  | Pexp_constant (c) -> line i ppf "Pexp_constant %a\n" fmt_constant c;
   | Pexp_let (rf, l, e) ->
-      line i "Pexp_let %a\n" fmt_rec_flag rf;
-      list i pattern_x_expression_def l;
-      expression i e;
+      line i ppf "Pexp_let %a\n" fmt_rec_flag rf;
+      list i pattern_x_expression_def ppf l;
+      expression i ppf e;
   | Pexp_function (p, eo, l) ->
-      line i "Pexp_function \"%s\"\n" p;
-      option i expression eo;
-      list i pattern_x_expression_case l;
+      line i ppf "Pexp_function \"%s\"\n" p;
+      option i expression ppf eo;
+      list i pattern_x_expression_case ppf l;
   | Pexp_apply (e, l) ->
-      line i "Pexp_apply\n";
-      expression i e;
-      list i label_x_expression l;
+      line i ppf "Pexp_apply\n";
+      expression i ppf e;
+      list i label_x_expression ppf l;
   | Pexp_match (e, l) ->
-      line i "Pexp_match\n";
-      expression i e;
-      list i pattern_x_expression_case l;
+      line i ppf "Pexp_match\n";
+      expression i ppf e;
+      list i pattern_x_expression_case ppf l;
   | Pexp_try (e, l) ->
-      line i "Pexp_try\n";
-      expression i e;
-      list i pattern_x_expression_case l;
+      line i ppf "Pexp_try\n";
+      expression i ppf e;
+      list i pattern_x_expression_case ppf l;
   | Pexp_tuple (l) ->
-      line i "Pexp_tuple\n";
-      list i expression l;
+      line i ppf "Pexp_tuple\n";
+      list i expression ppf l;
   | Pexp_construct (li, eo, b) ->
-      line i "Pexp_construct %a\n" fmt_longident li;
-      option i expression eo;
-      bool i b;
+      line i ppf "Pexp_construct %a\n" fmt_longident li;
+      option i expression ppf eo;
+      bool i ppf b;
   | Pexp_variant (l, eo) ->
-      line i "Pexp_variant `%s\n" l;
-      option i expression eo;
+      line i ppf "Pexp_variant `%s\n" l;
+      option i expression ppf eo;
   | Pexp_record (l, eo) ->
-      line i "Pexp_record\n";
-      list i longident_x_expression l;
-      option i expression eo;
+      line i ppf "Pexp_record\n";
+      list i longident_x_expression ppf l;
+      option i expression ppf eo;
   | Pexp_field (e, li) ->
-      line i "Pexp_field\n";
-      expression i e;
-      longident i li;
+      line i ppf "Pexp_field\n";
+      expression i ppf e;
+      longident i ppf li;
   | Pexp_setfield (e1, li, e2) ->
-      line i "Pexp_setfield\n";
-      expression i e1;
-      longident i li;
-      expression i e2;
+      line i ppf "Pexp_setfield\n";
+      expression i ppf e1;
+      longident i ppf li;
+      expression i ppf e2;
   | Pexp_array (l) ->
-      line i "Pexp_array\n";
-      list i expression l;
+      line i ppf "Pexp_array\n";
+      list i expression ppf l;
   | Pexp_ifthenelse (e1, e2, eo) ->
-      line i "Pexp_ifthenelse\n";
-      expression i e1;
-      expression i e2;
-      option i expression eo;
+      line i ppf "Pexp_ifthenelse\n";
+      expression i ppf e1;
+      expression i ppf e2;
+      option i expression ppf eo;
   | Pexp_sequence (e1, e2) ->
-      line i "Pexp_sequence\n";
-      expression i e1;
-      expression i e2;
+      line i ppf "Pexp_sequence\n";
+      expression i ppf e1;
+      expression i ppf e2;
   | Pexp_while (e1, e2) ->
-      line i "Pexp_while\n";
-      expression i e1;
-      expression i e2;
+      line i ppf "Pexp_while\n";
+      expression i ppf e1;
+      expression i ppf e2;
   | Pexp_for (s, e1, e2, df, e3) ->
-      line i "Pexp_for \"%s\" %a\n" s fmt_direction_flag df;
-      expression i e1;
-      expression i e2;
-      expression i e3;
+      line i ppf "Pexp_for \"%s\" %a\n" s fmt_direction_flag df;
+      expression i ppf e1;
+      expression i ppf e2;
+      expression i ppf e3;
   | Pexp_constraint (e, cto1, cto2) ->
-      line i "Pexp_constraint\n";
-      expression i e;
-      option i core_type cto1;
-      option i core_type cto2;
+      line i ppf "Pexp_constraint\n";
+      expression i ppf e;
+      option i core_type ppf cto1;
+      option i core_type ppf cto2;
   | Pexp_when (e1, e2) ->
-      line i "Pexp_when\n";
-      expression i e1;
-      expression i e2;
+      line i ppf "Pexp_when\n";
+      expression i ppf e1;
+      expression i ppf e2;
   | Pexp_send (e, s) ->
-      line i "Pexp_send \"%s\"\n" s;
-      expression i e;
-  | Pexp_new (li) -> line i "Pexp_new %a\n" fmt_longident li;
+      line i ppf "Pexp_send \"%s\"\n" s;
+      expression i ppf e;
+  | Pexp_new (li) -> line i ppf "Pexp_new %a\n" fmt_longident li;
   | Pexp_setinstvar (s, e) ->
-      line i "Pexp_setinstvar \"%s\"\n" s;
-      expression i e;
+      line i ppf "Pexp_setinstvar \"%s\"\n" s;
+      expression i ppf e;
   | Pexp_override (l) ->
-      line i "Pexp_override\n";
-      list i string_x_expression l;
+      line i ppf "Pexp_override\n";
+      list i string_x_expression ppf l;
   | Pexp_letmodule (s, me, e) ->
-      line i "Pexp_letmodule \"%s\"\n" s;
-      module_expr i me;
-      expression i e;
+      line i ppf "Pexp_letmodule \"%s\"\n" s;
+      module_expr i ppf me;
+      expression i ppf e;
 
-and value_description i x =
-  line i "value_description\n";
-  core_type (i+1) x.pval_type;
-  list (i+1) string x.pval_prim;
+and value_description i ppf x =
+  line i ppf "value_description\n";
+  core_type (i+1) ppf x.pval_type;
+  list (i+1) string ppf x.pval_prim;
 
-and type_declaration i x =
-  line i "type_declaration %a\n" fmt_location x.ptype_loc;
+and type_declaration i ppf x =
+  line i ppf "type_declaration %a\n" fmt_location x.ptype_loc;
   let i = i+1 in
-  line i "ptype_params =\n";
-  list (i+1) string x.ptype_params;
-  line i "ptype_cstrs =\n";
-  list (i+1) core_type_x_core_type_x_location x.ptype_cstrs;
-  line i "ptype_kind =\n";
-  type_kind (i+1) x.ptype_kind;
-  line i "ptype_manifest =\n";
-  option (i+1) core_type x.ptype_manifest;
-
-and type_kind i x =
+  line i ppf "ptype_params =\n";
+  list (i+1) string ppf x.ptype_params;
+  line i ppf "ptype_cstrs =\n";
+  list (i+1) core_type_x_core_type_x_location ppf x.ptype_cstrs;
+  line i ppf "ptype_kind =\n";
+  type_kind (i+1) ppf x.ptype_kind;
+  line i ppf "ptype_manifest =\n";
+  option (i+1) core_type ppf x.ptype_manifest;
+
+and type_kind i ppf x =
   match x with
-  | Ptype_abstract -> line i "Ptype_abstract\n";
+  | Ptype_abstract -> line i ppf "Ptype_abstract\n"
   | Ptype_variant (l) ->
-      line i "Ptype_variant\n";
-      list (i+1) string_x_core_type_list l;
+      line i ppf "Ptype_variant\n";
+      list (i+1) string_x_core_type_list ppf l;
   | Ptype_record (l) ->
-      line i "Ptype_record\n";
-      list (i+1) string_x_mutable_flag_x_core_type l;
+      line i ppf "Ptype_record\n";
+      list (i+1) string_x_mutable_flag_x_core_type ppf l;
 
-and exception_declaration i x = list i core_type x
+and exception_declaration i ppf x = list i core_type ppf x
 
-and class_type i x =
-  line i "class_type %a\n" fmt_location x.pcty_loc;
+and class_type i ppf x =
+  line i ppf "class_type %a\n" fmt_location x.pcty_loc;
   let i = i+1 in
   match x.pcty_desc with
   | Pcty_constr (li, l) ->
-      line i "Pcty_constr %a\n" fmt_longident li;
-      list i core_type l;
+      line i ppf "Pcty_constr %a\n" fmt_longident li;
+      list i core_type ppf l;
   | Pcty_signature (cs) ->
-      line i "Pcty_signature\n";
-      class_signature i cs;
+      line i ppf "Pcty_signature\n";
+      class_signature i ppf cs;
   | Pcty_fun (l, co, cl) ->
-      line i "Pcty_fun \"%s\"\n" l;
-      core_type i co;
-      class_type i cl;
+      line i ppf "Pcty_fun \"%s\"\n" l;
+      core_type i ppf co;
+      class_type i ppf cl;
 
-and class_signature i (ct, l) =
-  line i "class_signature\n";
-  core_type (i+1) ct;
-  list (i+1) class_type_field l;
+and class_signature i ppf (ct, l) =
+  line i ppf "class_signature\n";
+  core_type (i+1) ppf ct;
+  list (i+1) class_type_field ppf l;
 
-and class_type_field i x =
+and class_type_field i ppf x =
   match x with
   | Pctf_inher (ct) ->
-      line i "Pctf_inher\n";
-      class_type i ct;
+      line i ppf "Pctf_inher\n";
+      class_type i ppf ct;
   | Pctf_val (s, mf, cto, loc) ->
-      line i "Pctf_val \"%s\" %a %a\n" s fmt_mutable_flag mf fmt_location loc;
-      option i core_type cto;
+      line i ppf
+        "Pctf_val \"%s\" %a %a\n" s fmt_mutable_flag mf fmt_location loc;
+      option i core_type ppf cto;
   | Pctf_virt (s, pf, ct, loc) ->
-      line i "Pctf_virt \"%s\" %a %a\n" s fmt_private_flag pf fmt_location loc;
+      line i ppf
+        "Pctf_virt \"%s\" %a %a\n" s fmt_private_flag pf fmt_location loc;
   | Pctf_meth (s, pf, ct, loc) ->
-      line i "Pctf_meth \"%s\" %a %a\n" s fmt_private_flag pf fmt_location loc;
+      line i ppf
+        "Pctf_meth \"%s\" %a %a\n" s fmt_private_flag pf fmt_location loc;
   | Pctf_cstr (ct1, ct2, loc) ->
-      line i "Pctf_cstr %a\n" fmt_location loc;
-      core_type i ct1;
-      core_type i ct2;
+      line i ppf "Pctf_cstr %a\n" fmt_location loc;
+      core_type i ppf ct1;
+      core_type i ppf ct2;
 
-and class_description i x =
-  line i "class_description %a\n" fmt_location x.pci_loc;
+and class_description i ppf x =
+  line i ppf "class_description %a\n" fmt_location x.pci_loc;
   let i = i+1 in
-  line i "pci_virt = %a\n" fmt_virtual_flag x.pci_virt;
-  line i "pci_params =\n";
-  string_list_x_location (i+1) x.pci_params;
-  line i "pci_name = \"%s\"\n" x.pci_name;
-  line i "pci_expr =\n";
-  class_type (i+1) x.pci_expr;
-
-and class_type_declaration i x =
-  line i "class_type_declaration %a\n" fmt_location x.pci_loc;
+  line i ppf "pci_virt = %a\n" fmt_virtual_flag x.pci_virt;
+  line i ppf "pci_params =\n";
+  string_list_x_location (i+1) ppf x.pci_params;
+  line i ppf "pci_name = \"%s\"\n" x.pci_name;
+  line i ppf "pci_expr =\n";
+  class_type (i+1) ppf x.pci_expr;
+
+and class_type_declaration i ppf x =
+  line i ppf "class_type_declaration %a\n" fmt_location x.pci_loc;
   let i = i+1 in
-  line i "pci_virt = %a\n" fmt_virtual_flag x.pci_virt;
-  line i "pci_params =\n";
-  string_list_x_location (i+1) x.pci_params;
-  line i "pci_name = \"%s\"\n" x.pci_name;
-  line i "pci_expr =\n";
-  class_type (i+1) x.pci_expr;
-
-and class_expr i x =
-  line i "class_expr %a\n" fmt_location x.pcl_loc;
+  line i ppf "pci_virt = %a\n" fmt_virtual_flag x.pci_virt;
+  line i ppf "pci_params =\n";
+  string_list_x_location (i+1) ppf x.pci_params;
+  line i ppf "pci_name = \"%s\"\n" x.pci_name;
+  line i ppf "pci_expr =\n";
+  class_type (i+1) ppf x.pci_expr;
+
+and class_expr i ppf x =
+  line i ppf "class_expr %a\n" fmt_location x.pcl_loc;
   let i = i+1 in
   match x.pcl_desc with
   | Pcl_constr (li, l) ->
-      line i "Pcl_constr %a\n" fmt_longident li;
-      list i core_type l;
+      line i ppf "Pcl_constr %a\n" fmt_longident li;
+      list i core_type ppf l;
   | Pcl_structure (cs) ->
-      line i "Pcl_structure\n";
-      class_structure i cs;
+      line i ppf "Pcl_structure\n";
+      class_structure i ppf cs;
   | Pcl_fun (l, eo, p, e) ->
-      line i "Pcl_fun\n";
-      label i l;
-      option i expression eo;
-      pattern i p;
-      class_expr i e;
+      line i ppf "Pcl_fun\n";
+      label i ppf l;
+      option i expression ppf eo;
+      pattern i ppf p;
+      class_expr i ppf e;
   | Pcl_apply (ce, l) ->
-      line i "Pcl_apply\n";
-      class_expr i ce;
-      list i label_x_expression l;
+      line i ppf "Pcl_apply\n";
+      class_expr i ppf ce;
+      list i label_x_expression ppf l;
   | Pcl_let (rf, l, ce) ->
-      line i "Pcl_let %a\n" fmt_rec_flag rf;
-      list i pattern_x_expression_def l;
-      class_expr i ce;
+      line i ppf "Pcl_let %a\n" fmt_rec_flag rf;
+      list i pattern_x_expression_def ppf l;
+      class_expr i ppf ce;
   | Pcl_constraint (ce, ct) ->
-      line i "Pcl_constraint\n";
-      class_expr i ce;
-      class_type i ct;
+      line i ppf "Pcl_constraint\n";
+      class_expr i ppf ce;
+      class_type i ppf ct;
 
-and class_structure i (p, l) =
-  line i "class_structure\n";
-  pattern (i+1) p;
-  list (i+1) class_field l;
+and class_structure i ppf (p, l) =
+  line i ppf "class_structure\n";
+  pattern (i+1) ppf p;
+  list (i+1) class_field ppf l;
 
-and class_field i x =
+and class_field i ppf x =
   match x with
   | Pcf_inher (ce, so) ->
       printf "Pcf_inher\n";
-      class_expr (i+1) ce;
-      option (i+1) string so;
+      class_expr (i+1) ppf ce;
+      option (i+1) string ppf so;
   | Pcf_val (s, mf, e, loc) ->
-      line i "Pcf_val \"%s\" %a %a\n" s fmt_mutable_flag mf fmt_location loc;
-      expression (i+1) e;
+      line i ppf
+        "Pcf_val \"%s\" %a %a\n" s fmt_mutable_flag mf fmt_location loc;
+      expression (i+1) ppf e;
   | Pcf_virt (s, pf, ct, loc) ->
-      line i "Pcf_virt \"%s\" %a %a\n" s fmt_private_flag pf fmt_location loc;
-      core_type (i+1) ct;
+      line i ppf
+        "Pcf_virt \"%s\" %a %a\n" s fmt_private_flag pf fmt_location loc;
+      core_type (i+1) ppf ct;
   | Pcf_meth (s, pf, e, loc) ->
-      line i "Pcf_meth \"%s\" %a %a\n" s fmt_private_flag pf fmt_location loc;
-      expression (i+1) e;
+      line i ppf
+        "Pcf_meth \"%s\" %a %a\n" s fmt_private_flag pf fmt_location loc;
+      expression (i+1) ppf e;
   | Pcf_cstr (ct1, ct2, loc) ->
-      line i "Pcf_cstr %a\n" fmt_location loc;
-      core_type (i+1) ct1;
-      core_type (i+1) ct2;
+      line i ppf "Pcf_cstr %a\n" fmt_location loc;
+      core_type (i+1) ppf ct1;
+      core_type (i+1) ppf ct2;
   | Pcf_let (rf, l, loc) ->
-      line i "Pcf_let %a %a\n" fmt_rec_flag rf fmt_location loc;
-      list (i+1) pattern_x_expression_def l;
+      line i ppf "Pcf_let %a %a\n" fmt_rec_flag rf fmt_location loc;
+      list (i+1) pattern_x_expression_def ppf l;
   | Pcf_init (e) ->
-      line i "Pcf_init\n";
-      expression (i+1) e;
+      line i ppf "Pcf_init\n";
+      expression (i+1) ppf e;
 
-and class_declaration i x =
-  line i "class_declaration %a\n" fmt_location x.pci_loc;
+and class_declaration i ppf x =
+  line i ppf "class_declaration %a\n" fmt_location x.pci_loc;
   let i = i+1 in
-  line i "pci_virt = %a\n" fmt_virtual_flag x.pci_virt;
-  line i "pci_params =\n";
-  string_list_x_location (i+1) x.pci_params;
-  line i "pci_name = \"%s\"\n" x.pci_name;
-  line i "pci_expr =\n";
-  class_expr (i+1) x.pci_expr;
-
-and module_type i x =
-  line i "module_type %a\n" fmt_location x.pmty_loc;
+  line i ppf "pci_virt = %a\n" fmt_virtual_flag x.pci_virt;
+  line i ppf "pci_params =\n";
+  string_list_x_location (i+1) ppf x.pci_params;
+  line i ppf "pci_name = \"%s\"\n" x.pci_name;
+  line i ppf "pci_expr =\n";
+  class_expr (i+1) ppf x.pci_expr;
+
+and module_type i ppf x =
+  line i ppf "module_type %a\n" fmt_location x.pmty_loc;
   let i = i+1 in
   match x.pmty_desc with
-  | Pmty_ident (li) -> line i "Pmty_ident (%a)\n" fmt_longident li;
+  | Pmty_ident (li) -> line i ppf "Pmty_ident (%a)\n" fmt_longident li;
   | Pmty_signature (s) ->
-      line i "Pmty_signature\n";
-      signature i s;
+      line i ppf "Pmty_signature\n";
+      signature i ppf s;
   | Pmty_functor (s, mt1, mt2) ->
-      line i "Pmty_functor \"%s\"\n" s;
-      module_type i mt1;
-      module_type i mt2;
+      line i ppf "Pmty_functor \"%s\"\n" s;
+      module_type i ppf mt1;
+      module_type i ppf mt2;
   | Pmty_with (mt, l) ->
-      line i "Pmty_with\n";
-      module_type i mt;
-      list i longident_x_with_constraint l;
+      line i ppf "Pmty_with\n";
+      module_type i ppf mt;
+      list i longident_x_with_constraint ppf l;
 
-and signature i x = list i signature_item x
+and signature i ppf x = list i signature_item ppf x
 
-and signature_item i x =
-  line i "signature_item %a\n" fmt_location x.psig_loc;
+and signature_item i ppf x =
+  line i ppf "signature_item %a\n" fmt_location x.psig_loc;
   let i = i+1 in
   match x.psig_desc with
   | Psig_value (s, vd) ->
-      line i "Psig_value \"%s\"\n" s;
-      value_description i vd;
+      line i ppf "Psig_value \"%s\"\n" s;
+      value_description i ppf vd;
   | Psig_type (l) ->
-      line i "Psig_type\n";
-      list i string_x_type_declaration l;
+      line i ppf "Psig_type\n";
+      list i string_x_type_declaration ppf l;
   | Psig_exception (s, ed) ->
-      line i "Psig_exception \"%s\"\n" s;
-      exception_declaration i ed;
+      line i ppf "Psig_exception \"%s\"\n" s;
+      exception_declaration i ppf ed;
   | Psig_module (s, mt) ->
-      line i "Psig_module \"%s\"\n" s;
-      module_type i mt;
+      line i ppf "Psig_module \"%s\"\n" s;
+      module_type i ppf mt;
   | Psig_modtype (s, md) ->
-      line i "Psig_modtype \"%s\"\n" s;
-      modtype_declaration i md;
-  | Psig_open (li) -> line i "Psig_open %a\n" fmt_longident li;
+      line i ppf "Psig_modtype \"%s\"\n" s;
+      modtype_declaration i ppf md;
+  | Psig_open (li) -> line i ppf "Psig_open %a\n" fmt_longident li;
   | Psig_include (mt) ->
-      line i "Psig_include\n";
-      module_type i mt;
+      line i ppf "Psig_include\n";
+      module_type i ppf mt;
   | Psig_class (l) ->
-      line i "Psig_class\n";
-      list i class_description l;
+      line i ppf "Psig_class\n";
+      list i class_description ppf l;
   | Psig_class_type (l) ->
-      line i "Psig_class_type\n";
-      list i class_type_declaration l;
+      line i ppf "Psig_class_type\n";
+      list i class_type_declaration ppf l;
 
-and modtype_declaration i x =
+and modtype_declaration i ppf x =
   match x with
-  | Pmodtype_abstract -> line i "Pmodtype_abstract\n";
+  | Pmodtype_abstract -> line i ppf "Pmodtype_abstract\n";
   | Pmodtype_manifest (mt) ->
-      line i "Pmodtype_manifest\n";
-      module_type (i+1) mt;
+      line i ppf "Pmodtype_manifest\n";
+      module_type (i+1) ppf mt;
 
-and with_constraint i x =
+and with_constraint i ppf x =
   match x with
   | Pwith_type (td) ->
-      line i "Pwith_type\n";
-      type_declaration (i+1) td;
-  | Pwith_module (li) -> line i "Pwith_module %a\n" fmt_longident li;
+      line i ppf "Pwith_type\n";
+      type_declaration (i+1) ppf td;
+  | Pwith_module (li) -> line i ppf "Pwith_module %a\n" fmt_longident li;
 
-and module_expr i x =
-  line i "module_expr %a\n" fmt_location x.pmod_loc;
+and module_expr i ppf x =
+  line i ppf "module_expr %a\n" fmt_location x.pmod_loc;
   let i = i+1 in
   match x.pmod_desc with
-  | Pmod_ident (li) -> line i "Pmod_ident %a\n" fmt_longident li;
+  | Pmod_ident (li) -> line i ppf "Pmod_ident %a\n" fmt_longident li;
   | Pmod_structure (s) ->
-      line i "Pmod_structure\n";
-      structure i s;
+      line i ppf "Pmod_structure\n";
+      structure i ppf s;
   | Pmod_functor (s, mt, me) ->
-      line i "Pmod_functor \"%s\"\n" s;
-      module_type i mt;
-      module_expr i me;
+      line i ppf "Pmod_functor \"%s\"\n" s;
+      module_type i ppf mt;
+      module_expr i ppf me;
   | Pmod_apply (me1, me2) ->
-      line i "Pmod_apply\n";
-      module_expr i me1;
-      module_expr i me2;
+      line i ppf "Pmod_apply\n";
+      module_expr i ppf me1;
+      module_expr i ppf me2;
   | Pmod_constraint (me, mt) ->
-      line i "Pmod_constraint\n";
-      module_expr i me;
-      module_type i mt;
+      line i ppf "Pmod_constraint\n";
+      module_expr i ppf me;
+      module_type i ppf mt;
 
-and structure i x = list i structure_item x
+and structure i ppf x = list i structure_item ppf x
 
-and structure_item i x =
-  line i "structure_item %a\n" fmt_location x.pstr_loc;
+and structure_item i ppf x =
+  line i ppf "structure_item %a\n" fmt_location x.pstr_loc;
   let i = i+1 in
   match x.pstr_desc with
   | Pstr_eval (e) ->
-      line i "Pstr_eval\n";
-      expression i e;
+      line i ppf "Pstr_eval\n";
+      expression i ppf e;
   | Pstr_value (rf, l) ->
-      line i "Pstr_value %a\n" fmt_rec_flag rf;
-      list i pattern_x_expression_def l;
+      line i ppf "Pstr_value %a\n" fmt_rec_flag rf;
+      list i pattern_x_expression_def ppf l;
   | Pstr_primitive (s, vd) ->
-      line i "Pstr_primitive \"%s\"\n" s;
-      value_description i vd;
+      line i ppf "Pstr_primitive \"%s\"\n" s;
+      value_description i ppf vd;
   | Pstr_type (l) ->
-      line i "Pstr_type\n";
-      list i string_x_type_declaration l;
+      line i ppf "Pstr_type\n";
+      list i string_x_type_declaration ppf l;
   | Pstr_exception (s, ed) ->
-      line i "Pstr_exception \"%s\"\n" s;
-      exception_declaration i ed;
+      line i ppf "Pstr_exception \"%s\"\n" s;
+      exception_declaration i ppf ed;
   | Pstr_module (s, me) ->
-      line i "Pstr_module \"%s\"\n" s;
-      module_expr i me;
+      line i ppf "Pstr_module \"%s\"\n" s;
+      module_expr i ppf me;
   | Pstr_modtype (s, mt) ->
-      line i "Pstr_modtype \"%s\"\n" s;
-      module_type i mt;
-  | Pstr_open (li) -> line i "Pstr_open %a\n" fmt_longident li;
+      line i ppf "Pstr_modtype \"%s\"\n" s;
+      module_type i ppf mt;
+  | Pstr_open (li) -> line i ppf "Pstr_open %a\n" fmt_longident li;
   | Pstr_class (l) ->
-      line i "Pstr_class\n";
-      list i class_declaration l;
+      line i ppf "Pstr_class\n";
+      list i class_declaration ppf l;
   | Pstr_class_type (l) ->
-      line i "Pstr_class_type\n";
-      list i class_type_declaration l;
-
-and string_x_type_declaration i (s, td) =
-  string i s;
-  type_declaration (i+1) td;
-
-and longident_x_with_constraint i (li, wc) =
-  line i "%a\n" fmt_longident li;
-  with_constraint (i+1) wc;
-
-and core_type_x_core_type_x_location i (ct1, ct2, l) =
-  line i "<constraint> %a\n" fmt_location l;
-  core_type (i+1) ct1;
-  core_type (i+1) ct2;
-
-and string_x_core_type_list i (s, l) =
-  string i s;
-  list (i+1) core_type l;
-
-and string_x_mutable_flag_x_core_type i (s, mf, ct) =
-  line i "\"%s\" %a\n" s fmt_mutable_flag mf;
-  core_type (i+1) ct;
-
-and string_list_x_location i (l, loc) =
-  line i "<params> %a\n" fmt_location loc;
-  list (i+1) string l;
-
-and longident_x_pattern i (li, p) =
-  line i "%a\n" fmt_longident li;
-  pattern (i+1) p;
-
-and pattern_x_expression_case i (p, e) =
-  line i "<case>\n";
-  pattern (i+1) p;
-  expression (i+1) e;
-
-and pattern_x_expression_def i (p, e) =
-  line i "<def>\n";
-  pattern (i+1) p;
-  expression (i+1) e;
-
-and string_x_expression i (s, e) =
-  line i "<override> \"%s\"\n" s;
-  expression (i+1) e;
-
-and longident_x_expression i (li, e) =
-  line i "%a\n" fmt_longident li;
-  expression (i+1) e;
-
-and label_x_expression i (l,e) =
-  line i "<label> \"%s\"\n" l;
-  expression (i+1) e;
-
-and label_x_bool_x_core_type_list i (l, b, ctl) =
-  line i "<row_field> \"%s\" %s\n" l (string_of_bool b);
-  list (i+1) core_type ctl
+      line i ppf "Pstr_class_type\n";
+      list i class_type_declaration ppf l;
+
+and string_x_type_declaration i ppf (s, td) =
+  string i ppf s;
+  type_declaration (i+1) ppf td;
+
+and longident_x_with_constraint i ppf (li, wc) =
+  line i ppf "%a\n" fmt_longident li;
+  with_constraint (i+1) ppf wc;
+
+and core_type_x_core_type_x_location i ppf (ct1, ct2, l) =
+  line i ppf "<constraint> %a\n" fmt_location l;
+  core_type (i+1) ppf ct1;
+  core_type (i+1) ppf ct2;
+
+and string_x_core_type_list i ppf (s, l) =
+  string i ppf s;
+  list (i+1) core_type ppf l;
+
+and string_x_mutable_flag_x_core_type i ppf (s, mf, ct) =
+  line i ppf "\"%s\" %a\n" s fmt_mutable_flag mf;
+  core_type (i+1) ppf ct;
+
+and string_list_x_location i ppf (l, loc) =
+  line i ppf "<params> %a\n" fmt_location loc;
+  list (i+1) string ppf l;
+
+and longident_x_pattern i ppf (li, p) =
+  line i ppf "%a\n" fmt_longident li;
+  pattern (i+1) ppf p;
+
+and pattern_x_expression_case i ppf (p, e) =
+  line i ppf "<case>\n";
+  pattern (i+1) ppf  p;
+  expression (i+1) ppf e;
+
+and pattern_x_expression_def i ppf (p, e) =
+  line i ppf "<def>\n";
+  pattern (i+1) ppf p;
+  expression (i+1) ppf e;
+
+and string_x_expression i ppf (s, e) =
+  line i ppf "<override> \"%s\"\n" s;
+  expression (i+1) ppf e;
+
+and longident_x_expression i ppf (li, e) =
+  line i ppf "%a\n" fmt_longident li;
+  expression (i+1) ppf e;
+
+and label_x_expression i ppf (l,e) =
+  line i ppf "<label> \"%s\"\n" l;
+  expression (i+1) ppf e;
+
+and label_x_bool_x_core_type_list i ppf (l, b, ctl) =
+  line i ppf "<row_field> \"%s\" %s\n" l (string_of_bool b);
+  list (i+1) core_type ppf ctl
 ;;
 
-let rec toplevel_phrase i x =
+let rec toplevel_phrase i ppf x =
   match x with
   | Ptop_def (s) ->
-      line i "Ptop_def\n";
-      structure (i+1) s;
+      line i ppf "Ptop_def\n";
+      structure (i+1) ppf s;
   | Ptop_dir (s, da) ->
-      line i "Ptop_dir \"%s\"\n" s;
-      directive_argument i da;
+      line i ppf "Ptop_dir \"%s\"\n" s;
+      directive_argument i ppf da;
 
-and directive_argument i x =
+and directive_argument i ppf x =
   match x with
-  | Pdir_none -> line i "Pdir_none\n"
-  | Pdir_string (s) -> line i "Pdir_string \"%s\"\n" s;
-  | Pdir_int (i) -> line i "Pdir_int %d\n" i;
-  | Pdir_ident (li) -> line i "Pdir_ident %a\n" fmt_longident li;
-  | Pdir_bool (b) -> line i "Pdir_bool %s\n" (string_of_bool b);
+  | Pdir_none -> line i ppf "Pdir_none\n"
+  | Pdir_string (s) -> line i ppf "Pdir_string \"%s\"\n" s;
+  | Pdir_int (i) -> line i ppf "Pdir_int %d\n" i;
+  | Pdir_ident (li) -> line i ppf "Pdir_ident %a\n" fmt_longident li;
+  | Pdir_bool (b) -> line i ppf "Pdir_bool %s\n" (string_of_bool b);
 ;;
 
-let interface x = list 0 signature_item x;;
+let interface ppf x = list 0 signature_item ppf x;;
 
-let implementation x = list 0 structure_item x;;
+let implementation ppf x = list 0 structure_item ppf x;;
 
-let top_phrase x = toplevel_phrase 0 x;;
+let top_phrase ppf x = toplevel_phrase 0 ppf x;;
diff --git a/parsing/printast.mli b/parsing/printast.mli
index 32c6e08bf..7ea148678 100644
--- a/parsing/printast.mli
+++ b/parsing/printast.mli
@@ -13,7 +13,8 @@
 (* $Id$ *)
 
 open Parsetree;;
+open Format;;
 
-val interface : signature_item list -> unit;;
-val implementation : structure_item list -> unit;;
-val top_phrase : toplevel_phrase -> unit;;
+val interface : formatter -> signature_item list -> unit;;
+val implementation : formatter -> structure_item list -> unit;;
+val top_phrase : formatter -> toplevel_phrase -> unit;;
diff --git a/parsing/syntaxerr.ml b/parsing/syntaxerr.ml
index e03cd77b2..82fcc7745 100644
--- a/parsing/syntaxerr.ml
+++ b/parsing/syntaxerr.ml
@@ -14,7 +14,7 @@
 
 (* Auxiliary type for reporting syntax errors *)
 
-open Formatmsg
+open Format
 
 type error =
     Unclosed of Location.t * string * Location.t * string
@@ -23,20 +23,19 @@ type error =
 exception Error of error
 exception Escape_error
 
-let report_error = function
-    Unclosed(opening_loc, opening, closing_loc, closing) ->
+let report_error ppf = function
+  | Unclosed(opening_loc, opening, closing_loc, closing) ->
       if String.length !Location.input_name = 0
       && Location.highlight_locations opening_loc closing_loc
-      then printf "Syntax error: '%s' expected, \
+      then fprintf ppf "Syntax error: '%s' expected, \
                    the highlighted '%s' might be unmatched" closing opening
       else begin
-        Location.print closing_loc;
-        printf "Syntax error: '%s' expected@?" closing;
-        Location.print opening_loc;
-        printf "This '%s' might be unmatched" opening
+        fprintf ppf "%aSyntax error: '%s' expected@?"
+          Location.print closing_loc closing;
+        fprintf ppf "%aThis '%s' might be unmatched"
+          Location.print opening_loc opening 
       end
   | Other loc ->
-      Location.print loc;
-      print_string "Syntax error"
+      fprintf ppf "%aSyntax error" Location.print loc
 
 
diff --git a/parsing/syntaxerr.mli b/parsing/syntaxerr.mli
index 8526b159e..dba7f2902 100644
--- a/parsing/syntaxerr.mli
+++ b/parsing/syntaxerr.mli
@@ -14,6 +14,8 @@
 
 (* Auxiliary type for reporting syntax errors *)
 
+open Format
+
 type error =
     Unclosed of Location.t * string * Location.t * string
   | Other of Location.t
@@ -21,4 +23,4 @@ type error =
 exception Error of error
 exception Escape_error
 
-val report_error: error -> unit
+val report_error: formatter -> error -> unit
diff --git a/tools/ocamldep.ml b/tools/ocamldep.ml
index 2b106cbc7..f3f72e8b0 100644
--- a/tools/ocamldep.ml
+++ b/tools/ocamldep.ml
@@ -12,7 +12,7 @@
 
 (* $Id$ *)
 
-open Formatmsg
+open Format
 open Location
 open Longident
 open Parsetree
@@ -338,22 +338,19 @@ let file_dependencies source_file =
       with x ->
         close_in ic; raise x
     with x ->
-      set_output Format.err_formatter;
-      open_box 0;
-      begin match x with
-        Lexer.Error(err, start, stop) ->
-          Location.print {loc_start = start; loc_end = stop; loc_ghost = false};
+      let report_err = function
+      | Lexer.Error(err, start, stop) ->
+          fprintf Format.err_formatter "@[%a%a@]@."
+          Location.print {loc_start = start; loc_end = stop; loc_ghost = false}
           Lexer.report_error err
       | Syntaxerr.Error err ->
+          fprintf Format.err_formatter "@[%a@]@."
           Syntaxerr.report_error err
       | Sys_error msg ->
-          print_string "I/O error: "; print_string msg
-      | _ ->
-          close_box(); raise x
-      end;
-      close_box(); print_newline();
-      set_output Format.std_formatter;
-      error_occurred := true
+          fprintf Format.err_formatter "@[I/O error:@ %s@]@." msg
+      | x -> raise x in
+      error_occurred := true;
+      report_err x
   end
 
 (* Entry point *)
diff --git a/tools/ocamlprof.ml b/tools/ocamlprof.ml
index aa00c6267..a478ce04c 100644
--- a/tools/ocamlprof.ml
+++ b/tools/ocamlprof.ml
@@ -430,7 +430,7 @@ let process_file filename =
 
 (* Main function *)
 
-open Formatmsg
+open Format
 
 let usage = "Usage: ocamlprof <options> <files>\noptions are:"
 
@@ -446,26 +446,25 @@ let main () =
       ] process_file usage;
     exit 0
   with x ->
-    set_output Format.err_formatter;
-    open_box 0;
-    begin match x with
-      Lexer.Error(err, start, stop) ->
-        Location.print {loc_start = start; loc_end = stop; loc_ghost = false};
+    let report_error ppf = function
+    | Lexer.Error(err, start, stop) ->
+        fprintf ppf "@[%a%a@]@."
+        Location.print {loc_start = start; loc_end = stop; loc_ghost = false}
         Lexer.report_error err
     | Syntaxerr.Error err ->
+        fprintf ppf "@[%a@]@."
         Syntaxerr.report_error err
     | Profiler msg ->
-        print_string msg
+        fprintf ppf "@[%s@]@." msg
 (*
     | Inversion(pos, next) ->
         print_string "Internal error: inversion at char "; print_int pos;
         print_string ", "; print_int next
 *)
     | Sys_error msg ->
-        print_string "I/O error: "; print_string msg
-    | _ ->
-        close_box(); raise x
-    end;
-    close_box(); print_newline(); exit 2
+        fprintf ppf "@[I/O error:@ %s@]@." msg
+    | x -> raise x in
+    report_error Format.err_formatter x;
+    exit 2
 
 let _ = main ()
diff --git a/toplevel/genprintval.ml b/toplevel/genprintval.ml
index 0e21ef131..6921529e5 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 f4732341c..832d40cbc 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 385fbcd49..c8302df0a 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 68140e59a..dd89eca9b 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 11aafc814..1af7209bf 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 fca2428be..83fa9ca23 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 945065b19..e8fe874d9 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 f7791cf50..79468b1ab 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 46d60919b..e76d3e169 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 67bdc54c3..ed7dc6e33 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
diff --git a/typing/env.ml b/typing/env.ml
index d077fa778..28e9d72fa 100644
--- a/typing/env.ml
+++ b/typing/env.ml
@@ -14,7 +14,6 @@
 
 (* Environment handling *)
 
-open Formatmsg
 open Config
 open Misc
 open Asttypes
@@ -816,16 +815,17 @@ let initial = Predef.build_initial_env add_type add_exception empty
 let summary env = env.summary
 
 (* Error report *)
-
-let report_error = function
-  | Not_an_interface filename ->
-      printf "%s@ is not a compiled interface" filename
-  | Corrupted_interface filename ->
-      printf "Corrupted compiled interface@ %s" filename
-  | Illegal_renaming(modname, filename) ->
-      printf "Wrong file naming: %s@ contains the compiled interface for@ %s"
-        filename modname
-  | Inconsistent_import(name, source1, source2) ->
-      printf "@[<hv>The compiled interfaces for %s@ and %s@ " source1 source2;
-      printf "make inconsistent assumptions over interface %s@]" name
-;;
+open Format
+
+let report_error ppf = function
+  | Not_an_interface filename -> fprintf ppf
+      "%s@ is not a compiled interface" filename
+  | Corrupted_interface filename -> fprintf ppf
+      "Corrupted compiled interface@ %s" filename
+  | Illegal_renaming(modname, filename) -> fprintf ppf
+      "Wrong file naming: %s@ contains the compiled interface for@ %s"
+      filename modname
+  | Inconsistent_import(name, source1, source2) -> fprintf ppf
+      "@[<hv>The compiled interfaces for %s@ and %s@ \
+              make inconsistent assumptions over interface %s@]"
+      source1 source2  name;;
diff --git a/typing/env.mli b/typing/env.mli
index 9064b1977..9045d6334 100644
--- a/typing/env.mli
+++ b/typing/env.mli
@@ -117,7 +117,9 @@ type error =
 
 exception Error of error
 
-val report_error: error -> unit
+open Format
+
+val report_error: formatter -> error -> unit
 
 (* Forward declaration to break mutual recursion with Includemod. *)
 val check_modtype_inclusion: (t -> module_type -> module_type -> unit) ref
diff --git a/typing/includeclass.ml b/typing/includeclass.ml
index c25ce7e6f..912f64ace 100644
--- a/typing/includeclass.ml
+++ b/typing/includeclass.ml
@@ -33,113 +33,72 @@ let class_declarations env cty1 cty2 =
         cty1.cty_params cty1.cty_type
         cty2.cty_params cty2.cty_type
 
-open Formatmsg
+open Format
 open Ctype
 
-let include_err =
+let include_err ppf =
   function
-    CM_Virtual_class ->
-      print_string "A class cannot be changed from virtual to concrete"
+  | CM_Virtual_class ->
+      fprintf ppf "A class cannot be changed from virtual to concrete"
   | CM_Parameter_arity_mismatch (ls, lp) ->
-      print_string
+      fprintf ppf
         "The classes do not have the same number of type parameters"     
   | CM_Type_parameter_mismatch trace ->
-      open_box 0;
-      Printtyp.unification_error false trace
-        (function () ->
-          print_string "One type parameter has type")
-        (function () ->
-          print_string "but is expected to have type");
-      close_box ()
+      fprintf ppf "@[%a@]"
+      (Printtyp.unification_error false trace
+        (function ppf ->
+          fprintf ppf "One type parameter has type"))
+        (function ppf ->
+          fprintf ppf "but is expected to have type")
   | CM_Class_type_mismatch (cty1, cty2) ->
-      open_box 0;
-      print_string "The class type";  print_break 1 2;
-      Printtyp.class_type cty1;
-      print_space ();
-      print_string "is not matched by the class type";
-      print_break 1 2;
-      Printtyp.class_type cty2;
-      close_box ()
+      fprintf ppf
+       "@[The class type@;<1 2>%a@ is not matched by the class type@;<1 2>%a@]"
+       Printtyp.class_type cty1 Printtyp.class_type cty2
   | CM_Parameter_mismatch trace ->
-      open_box 0;
-      Printtyp.unification_error false trace
-        (function () ->
-          print_string "One parameter has type")
-        (function () ->
-          print_string "but is expected to have type");
-      close_box ()
+      fprintf ppf "@[%a@]"
+      (Printtyp.unification_error false trace
+        (function ppf ->
+          fprintf ppf "One parameter has type"))
+        (function ppf ->
+          fprintf ppf "but is expected to have type")
   | CM_Val_type_mismatch (lab, trace) ->
-      open_box 0;
-      Printtyp.unification_error false trace
-        (function () ->
-          print_string "The instance variable ";
-          print_string lab; print_space ();
-          print_string "has type")
-        (function () ->
-          print_string "but is expected to have type");
-      close_box ()
+      fprintf ppf "@[%a@]"
+      (Printtyp.unification_error false trace
+        (function ppf ->
+          fprintf ppf "The instance variable %s@ has type" lab))
+        (function ppf ->
+          fprintf ppf "but is expected to have type")
   | CM_Meth_type_mismatch (lab, trace) ->
-      open_box 0;
-      Printtyp.unification_error false trace
-        (function () ->
-          print_string "The method ";
-          print_string lab; print_space ();
-          print_string "has type")
-        (function () ->
-          print_string "but is expected to have type");
-      close_box ()
+      fprintf ppf "@[%a@]"
+      (Printtyp.unification_error false trace
+        (function ppf ->
+          fprintf ppf "The method %s@ has type" lab))
+        (function ppf ->
+          fprintf ppf "but is expected to have type")
   | CM_Non_mutable_value lab ->
-      open_box 0;
-      print_string "The non-mutable instance variable ";
-      print_string lab;
-      print_string " cannot become mutable";
-      close_box ()
+      fprintf ppf
+       "@[The non-mutable instance variable %s cannot become mutable@]" lab
   | CM_Missing_value lab ->
-      open_box 0;
-      print_string "The first class type has no instance variable ";
-      print_string lab;
-      close_box ()
+      fprintf ppf "@[The first class type has no instance variable %s@]" lab
   | CM_Missing_method lab ->
-      open_box 0;
-      print_string "The first class type has no method ";
-      print_string lab;
-      close_box ()
+      fprintf ppf "@[The first class type has no method %s@]" lab
   | CM_Hide_public lab ->
-      open_box 0;
-      print_string "The public method ";
-      print_string lab;
-      print_string " cannot be hidden";
-      close_box ()
+     fprintf ppf "@[The public method %s cannot be hidden@]" lab
   | CM_Hide_virtual lab ->
-      open_box 0;
-      print_string "The virtual method ";
-      print_string lab;
-      print_string " cannot be hidden";
-      close_box ()
+      fprintf ppf "@[The virtual method %s cannot be hidden@]" lab
   | CM_Public_method lab ->
-      open_box 0;
-      print_string "The public method ";
-      print_string lab;
-      print_string " cannot become private";
-      close_box ()
+      fprintf ppf "@[The public method %s cannot become private" lab
   | CM_Virtual_method lab ->
-      open_box 0;
-      print_string "The virtual method ";
-      print_string lab;
-      print_string " cannot become concrete";
-      close_box ()
+      fprintf ppf "@[The virtual method %s  cannot become concrete" lab
   | CM_Private_method lab ->
-      open_box 0;
-      print_string "The private method ";
-      print_string lab;
-      print_string " cannot become public";
-      close_box ()
+      fprintf ppf "The private method %s cannot become public" lab
+
+let report_error ppf = function
+  |  [] -> ()
+  | err :: errs ->
+      let print_errs ppf errs =
+         List.iter (fun err -> fprintf ppf "@ %a" include_err err) errs in
+      fprintf ppf "@[<v>%a%a@]" include_err err print_errs errs
+
+
 
-let report_error errlist =
-  match errlist with
-    [] -> ()
-  | err :: rem ->
-      open_vbox 0;
-      include_err err;
-      List.iter (fun err -> print_space(); include_err err) rem;
-      close_box()
diff --git a/typing/includeclass.mli b/typing/includeclass.mli
index 9bc840a17..5596056d0 100644
--- a/typing/includeclass.mli
+++ b/typing/includeclass.mli
@@ -17,6 +17,7 @@
 open Types
 open Typedtree
 open Ctype
+open Format
 
 val class_types:
         Env.t -> class_type -> class_type -> class_match_failure list
@@ -27,4 +28,4 @@ val class_declarations:
         Env.t -> class_declaration -> class_declaration ->
         class_match_failure list
 
-val report_error: class_match_failure list -> unit
+val report_error: formatter -> class_match_failure list -> unit
diff --git a/typing/includemod.ml b/typing/includemod.ml
index 0f5dd3025..c0c89e751 100644
--- a/typing/includemod.ml
+++ b/typing/includemod.ml
@@ -315,88 +315,64 @@ let type_declarations env id decl1 decl2 =
 
 (* Error report *)
 
-open Formatmsg
+open Format
 open Printtyp
 
-let include_err = function
-    Missing_field id ->
-      print_string "The field `"; ident id; 
-      print_string "' is required but not provided"
+let include_err ppf = function
+  | Missing_field id ->
+      fprintf ppf "The field `%a' is required but not provided" ident id
   | Value_descriptions(id, d1, d2) ->
-      open_hvbox 2;
-      print_string "Values do not match:"; print_space();
-      value_description id d1; 
-      print_break 1 (-2);
-      print_string "is not included in"; print_space();
-      value_description id d2;
-      close_box()
+      fprintf ppf
+       "@[<hv 2>Values do not match:@ \
+        %a@;<1 -2>is not included in@ %a@]"
+       (value_description id) d1 (value_description id) d2
   | Type_declarations(id, d1, d2) ->
-      open_hvbox 2;
-      print_string "Type declarations do not match:"; print_space();
-      type_declaration id d1; 
-      print_break 1 (-2);
-      print_string "is not included in"; print_space();
-      type_declaration id d2;
-      close_box()
+      fprintf ppf
+       "@[<hv 2>Type declarations do not match:@ \
+        %a@;<1 -2>is not included in@ %a@]"
+       (type_declaration id) d1
+       (type_declaration id) d2
   | Exception_declarations(id, d1, d2) ->
-      open_hvbox 2;
-      print_string "Exception declarations do not match:"; print_space();
-      exception_declaration id d1; 
-      print_break 1 (-2);
-      print_string "is not included in"; print_space();
-      exception_declaration id d2;
-      close_box()
+      fprintf ppf
+       "@[<hv 2>Exception declarations do not match:@ \
+        %a@;<1 -2>is not included in@ %a@]"
+      (exception_declaration id) d1
+      (exception_declaration id) d2
   | Module_types(mty1, mty2)->
-      open_hvbox 2;
-      print_string "Modules do not match:"; print_space();
-      modtype mty1;
-      print_break 1 (-2);
-      print_string "is not included in"; print_space();
-      modtype mty2;
-      close_box()
+      fprintf ppf
+       "@[<hv 2>Modules do not match:@ \
+        %a@;<1 -2>is not included in@ %a@]"
+      modtype mty1
+      modtype mty2
   | Modtype_infos(id, d1, d2) ->
-      open_hvbox 2;
-      print_string "Module type declarations do not match:"; print_space();
-      modtype_declaration id d1; 
-      print_break 1 (-2);
-      print_string "is not included in"; print_space();
-      modtype_declaration id d2;
-      close_box()
+      fprintf ppf
+       "@[<hv 2>Module type declarations do not match:@ \
+        %a@;<1 -2>is not included in@ %a@]"
+      (modtype_declaration id) d1
+      (modtype_declaration id) d2
   | Modtype_permutation ->
-      print_string "Illegal permutation of structure fields"
+      fprintf ppf "Illegal permutation of structure fields"
   | Interface_mismatch(impl_name, intf_name) ->
-      open_box 0;
-      print_string "The implementation "; print_string impl_name;
-      print_space(); print_string "does not match the interface ";
-      print_string intf_name;
-      print_string ":";
-      close_box()
+      fprintf ppf "@[The implementation %s@ does not match the interface %s:" 
+       impl_name intf_name
   | Class_type_declarations(id, d1, d2, reason) ->
-      open_hvbox 2;
-      print_string "Class type declarations do not match:"; print_space();
-      Printtyp.cltype_declaration id d1; 
-      print_break 1 (-2);
-      print_string "is not included in"; print_space();
-      Printtyp.cltype_declaration id d2;
-      close_box();
-      print_space ();
+      fprintf ppf
+       "@[<hv 2>Class type declarations do not match:@ \
+        %a@;<1 -2>is not included in@ %a@]@ %a"
+      (Printtyp.cltype_declaration id) d1
+      (Printtyp.cltype_declaration id) d2
       Includeclass.report_error reason
   | Class_declarations(id, d1, d2, reason) ->
-      open_hvbox 2;
-      print_string "Class declarations do not match:"; print_space();
-      Printtyp.class_declaration id d1; 
-      print_break 1 (-2);
-      print_string "is not included in"; print_space();
-      Printtyp.class_declaration id d2;
-      close_box();
-      print_space ();
+      fprintf ppf
+       "@[<hv 2>Class declarations do not match:@ \
+        %a@;<1 -2>is not included in@ %a@]@ %a"
+      (Printtyp.class_declaration id) d1
+      (Printtyp.class_declaration id) d2
       Includeclass.report_error reason
 
-let report_error errlist =
-  match errlist with
-    [] -> ()
-  | err :: rem ->
-      open_vbox 0;
-      include_err err;
-      List.iter (fun err -> print_space(); include_err err) rem;
-      close_box()
+let report_error ppf = function
+  |  [] -> ()
+  | err :: errs ->
+      let print_errs ppf errs =
+         List.iter (fun err -> fprintf ppf "@ %a" include_err err) errs in
+      fprintf ppf "@[<v>%a%a@]" include_err err print_errs errs
diff --git a/typing/includemod.mli b/typing/includemod.mli
index 22c20472b..cfd8003cc 100644
--- a/typing/includemod.mli
+++ b/typing/includemod.mli
@@ -16,6 +16,7 @@
 
 open Types
 open Typedtree
+open Format
 
 val modtypes: Env.t -> module_type -> module_type -> module_coercion
 val signatures: Env.t -> signature -> signature -> module_coercion
@@ -42,4 +43,4 @@ type error =
 
 exception Error of error list
 
-val report_error: error list -> unit
+val report_error: formatter -> error list -> unit
diff --git a/typing/parmatch.ml b/typing/parmatch.ml
index 88380a331..a776851b9 100644
--- a/typing/parmatch.ml
+++ b/typing/parmatch.ml
@@ -811,7 +811,7 @@ let check_partial tdefs loc casel =
   match r with
   | Rnone -> Total
   | Rok ->
-      Location.print_warning loc (Warnings.Partial_match "");
+      Location.prerr_warning loc (Warnings.Partial_match "");
       Partial
   | Rsome [v] ->
       let errmsg =
@@ -822,7 +822,7 @@ let check_partial tdefs loc casel =
           Buffer.contents buf
         with _ ->
           "" in
-      Location.print_warning loc (Warnings.Partial_match errmsg);
+      Location.prerr_warning loc (Warnings.Partial_match errmsg);
       Partial
   | _ ->
       fatal_error "Parmatch.check_partial"
@@ -849,9 +849,9 @@ let check_unused tdefs casel =
         | Rok -> false
         | _ -> assert false)
       then
-        Location.print_warning (location_of_clause qs) Warnings.Unused_match
+        Location.prerr_warning (location_of_clause qs) Warnings.Unused_match
       with e ->
-        Location.print_warning (location_of_clause qs)
+        Location.prerr_warning (location_of_clause qs)
           (Warnings.Other "Fatal Error") ;
         raise e)
     prefs
diff --git a/typing/printtyp.ml b/typing/printtyp.ml
index 8a76b3e6e..f121f5385 100644
--- a/typing/printtyp.ml
+++ b/typing/printtyp.ml
@@ -16,7 +16,8 @@
 
 open Misc
 open Ctype
-open Formatmsg
+open Format
+(*open Formatmsg*)
 open Longident
 open Path
 open Asttypes
@@ -25,30 +26,28 @@ open Btype
 
 (* Print a long identifier *)
 
-let rec longident = function
-    Lident s -> print_string s
-  | Ldot(p, s) -> longident p; print_string "."; print_string s
-  | Lapply(p1, p2) ->
-      longident p1; print_string "("; longident p2; print_string ")"
+let rec longident ppf = function
+  | Lident s -> fprintf ppf "%s" s
+  | Ldot(p, s) -> fprintf ppf "%a.%s" longident p s
+  | Lapply(p1, p2) -> fprintf ppf "%a(%a)" longident p1 longident p2
 
 (* Print an identifier *)
 
-let ident id =
-  print_string(Ident.name id)
+let ident ppf id = fprintf ppf "%s" (Ident.name id)
 
 (* Print a path *)
 
 let ident_pervasive = Ident.create_persistent "Pervasives"
 
-let rec path = function
-    Pident id ->
-      ident id
+let rec path ppf = function
+  | Pident id ->
+      ident ppf id
   | Pdot(Pident id, s, pos) when Ident.same id ident_pervasive ->
-      print_string s
+      fprintf ppf "%s" s
   | Pdot(p, s, pos) ->
-      path p; print_string "."; print_string s
+      fprintf ppf "%a.%s" path p s
   | Papply(p1, p2) ->
-      path p1; print_string "("; path p2; print_string ")"
+      fprintf ppf "%a(%a)" path p1 path p2
 
 (* Print a type expression *)
 
@@ -62,10 +61,9 @@ let new_name () =
     if !name_counter < 26
     then String.make 1 (Char.chr(97 + !name_counter)) 
     else String.make 1 (Char.chr(97 + !name_counter mod 26)) ^
-           string_of_int(!name_counter / 26)
-  in
-    incr name_counter;
-    name
+           string_of_int(!name_counter / 26) in
+  incr name_counter;
+  name
 
 let name_of_type t =
   try List.assq t !names with Not_found ->
@@ -73,85 +71,80 @@ let name_of_type t =
     names := (t, name) :: !names;
     name
 
-let print_name_of_type t =
-  print_string (name_of_type t)
-
-let check_name_of_type t =
-  ignore(name_of_type t)
+let check_name_of_type t = ignore(name_of_type t)
 
 (*
 let remove_name_of_type t =
   names := List.remove_assq t !names
 *)
 
+let print_name_of_type ppf t = fprintf ppf "%s" (name_of_type t)
+
 let visited_objects = ref ([] : type_expr list)
 let aliased = ref ([] : type_expr list)
 
+let add_alias px =
+  if not (List.memq px !aliased) then aliased := px :: !aliased
+
 let proxy ty =
   let ty = repr ty in
   match ty.desc with
-    Tvariant row -> Btype.row_more row
+  | Tvariant row -> Btype.row_more row
   | _ -> ty
 
 let namable_row row =
   row.row_name <> None && row.row_closed &&
   List.for_all
-    (fun (_,f) -> match row_field_repr f with
-      Reither(c,l,_) -> if c then l = [] else List.length l = 1
-    | _ -> true)
+    (fun (_, f) ->
+       match row_field_repr f with
+       | Reither(c, l, _) -> if c then l = [] else List.length l = 1
+       | _ -> true)
     row.row_fields
 
 let rec mark_loops_rec visited ty =
   let ty = repr ty in
   let px = proxy ty in
-  if List.memq px visited then begin
-    if not (List.memq px !aliased) then
-      aliased := px :: !aliased
-  end else
+  if List.memq px visited then add_alias px else
     let visited = px :: visited in
     match ty.desc with
-      Tvar                -> ()
+    | Tvar -> ()
     | Tarrow(_, ty1, ty2) ->
         mark_loops_rec visited ty1; mark_loops_rec visited ty2
-    | Ttuple tyl          -> List.iter (mark_loops_rec visited) tyl
-    | Tconstr(_, tyl, _)  ->
+    | Ttuple tyl -> List.iter (mark_loops_rec visited) tyl
+    | Tconstr(_, tyl, _) ->
         List.iter (mark_loops_rec visited) tyl
-    | Tvariant row        ->
+    | Tvariant row ->
         let row = row_repr row in
-        if List.memq px !visited_objects then begin
-          if not (List.memq px !aliased) then
-            aliased := px :: !aliased
-        end else begin
+        if List.memq px !visited_objects then add_alias px else
+         begin
           if not (static_row row) then
             visited_objects := px :: !visited_objects;
           match row.row_name with
-            Some(p, tyl) when namable_row row ->
+          | Some(p, tyl) when namable_row row ->
               List.iter (mark_loops_rec visited) tyl
           | _ ->
               iter_row (mark_loops_rec visited) row
-        end
-    | Tobject (fi, nm)    ->
-        if List.memq px !visited_objects then begin
-          if not (List.memq px !aliased) then
-            aliased := px :: !aliased
-        end else begin
+         end
+    | Tobject (fi, nm) ->
+        if List.memq px !visited_objects then add_alias px else
+         begin
           if opened_object ty then
             visited_objects := px :: !visited_objects;
           let name =
             match !nm with
-              None -> None
-            | Some (n, v::l) ->
+            | None -> None
+            | Some (n, v :: l) ->
                 let v' = repr v in
                 begin match v'.desc with
-                  Tvar -> Some (n, v'::l)
-                | _    -> None
+                | Tvar -> Some (n, v' :: l)
+                | _ -> None
                 end
             | _ ->
                 fatal_error "Printtyp.mark_loops_rec"
           in
           nm := name;
           begin match !nm with
-            None ->
+          | None ->
               mark_loops_rec visited fi
           | Some (_, l) ->
               List.iter (mark_loops_rec visited) l
@@ -161,13 +154,13 @@ let rec mark_loops_rec visited ty =
         mark_loops_rec visited ty1; mark_loops_rec visited ty2
     | Tfield(_, _, _, ty2) ->
         mark_loops_rec visited ty2
-    | Tnil                -> ()
-    | Tsubst ty           ->  mark_loops_rec visited ty
-    | Tlink _             -> fatal_error "Printtyp.mark_loops_rec (2)"
+    | Tnil -> ()
+    | Tsubst ty -> mark_loops_rec visited ty
+    | Tlink _ -> fatal_error "Printtyp.mark_loops_rec (2)"
 
 let mark_loops ty =
   normalize_type Env.empty ty;
-  mark_loops_rec [] ty
+  mark_loops_rec [] ty;;
 
 let reset_loop_marks () =
   visited_objects := []; aliased := []
@@ -175,273 +168,203 @@ let reset_loop_marks () =
 let reset () =
   reset_names (); reset_loop_marks ()
 
-(* disabled in classic mode when printing an unification error *)
+let reset_and_mark_loops ty =
+  reset (); mark_loops ty;;
+
+let reset_and_mark_loops_list tyl =
+ reset (); List.iter mark_loops tyl;;
+
+(* Disabled in classic mode when printing an unification error *)
 let print_labels = ref true
-let print_label l =
-  if !print_labels && l <> "" || is_optional l then begin
-    print_string l;
-    print_char ':'
-  end
+let print_label ppf l =
+  if !print_labels && l <> "" || is_optional l then fprintf ppf "%s:" l
 
-let rec print_list pr sep = function
-    [] -> ()
-  | [a] -> pr a
-  | a::l -> pr a; sep (); print_list pr sep l
+let rec print_list pr sep ppf = function
+  | [] -> ()
+  | [a] -> pr ppf a
+  | a :: l -> pr ppf a; sep (); print_list pr sep ppf l;;
 
-let rec typexp sch prio0 ty =
+let rec typexp sch prio0 ppf ty =
   let ty = repr ty in
   let px = proxy ty in
-  if List.mem_assq px !names then begin
-    if (px.desc = Tvar) && sch && (px.level <> generic_level)
-    then print_string "'_"
-    else print_string "'";
-    print_name_of_type px
-  end else begin
-    let alias = List.memq px !aliased in
-    if alias then begin
-      check_name_of_type px;
-      if prio0 >= 1 then begin open_box 1; print_string "(" end
-      else open_box 0
-    end;
-    let prio = if alias then 0 else prio0 in
-    begin match ty.desc with
-      Tvar ->
-        if (not sch) or ty.level = generic_level
-        then print_string "'"
-        else print_string "'_";
-        print_name_of_type ty
+  if List.mem_assq px !names then
+   let mark = if px.desc = Tvar then non_gen_mark sch px else "" in
+   fprintf ppf "'%s%a" mark print_name_of_type px else
+
+  let pr_typ ppf prio =
+   (match ty.desc with
+    | Tvar ->
+        fprintf ppf "'%s%a" (non_gen_mark sch ty) print_name_of_type ty
     | Tarrow(l, ty1, ty2) ->
-        if prio >= 2 then begin open_box 1; print_string "(" end
-                     else open_box 0;
-        print_label l;
-        if is_optional l then
-          match (repr ty1).desc with
-            Tconstr(path, [ty], _) when path = Predef.path_option ->
-              typexp sch 2 ty
-          | _ -> assert false
-        else
-          typexp sch 2 ty1;
-        print_string " ->"; print_space();
-        typexp sch 1 ty2;
-        if prio >= 2 then print_string ")";
-        close_box()
+        let pr_arrow l ty1 ppf ty2 =
+          print_label ppf l;
+          if is_optional l then
+            match (repr ty1).desc with
+            | Tconstr(path, [ty], _) when path = Predef.path_option ->
+                typexp sch 2 ppf ty
+            | _ -> assert false
+          else typexp sch 2 ppf ty1;
+          fprintf ppf " ->@ %a" (typexp sch 1) ty2 in
+        if prio >= 2
+        then fprintf ppf "@[<1>(%a)@]" (pr_arrow l ty1) ty2
+        else fprintf ppf "@[<0>%a@]" (pr_arrow l ty1) ty2
     | Ttuple tyl ->
-        if prio >= 3 then begin open_box 1; print_string "(" end
-                     else open_box 0;
-        typlist sch 3 " *" tyl;
-        if prio >= 3 then print_string ")";
-        close_box()
+        if prio >= 3
+        then fprintf ppf "@[<1>(%a)@]" (typlist sch 3 " *") tyl
+        else fprintf ppf "@[<0>%a@]" (typlist sch 3 " *") tyl
     | Tconstr(p, tyl, abbrev) ->
-        open_box 0;
-        begin match tyl with
-          [] -> ()
-        | [ty1] ->
-            typexp sch 3 ty1; print_space()
-        | tyl ->
-            open_box 1; print_string "("; typlist sch 0 "," tyl;
-            print_string ")"; close_box(); print_space()
-        end;
-        path p;
-        close_box()
+        fprintf ppf "@[%a%a@]" (typargs sch) tyl path p
     | Tvariant row ->
         let row = row_repr row in
         let fields =
           if row.row_closed then
-            List.filter (fun (_,f) -> row_field_repr f <> Rabsent)
+            List.filter (fun (_, f) -> row_field_repr f <> Rabsent)
               row.row_fields
-          else row.row_fields
-        in
+          else row.row_fields in
         let present =
           List.filter
-            (fun (_,f) -> match row_field_repr f with
-            | Rpresent _ -> true
-            | _ -> false)
+            (fun (_, f) ->
+               match row_field_repr f with
+               | Rpresent _ -> true
+               | _ -> false)
             fields in
         let all_present = List.length present = List.length fields in
+        let pr_present ppf l =
+          fprintf ppf "@[%a@]"
+            (print_list (fun ppf (s, _) -> fprintf ppf "@ | `%s" s) ignore)
+            l in
         begin match row.row_name with
-        | Some(p,tyl) when namable_row row ->
-            open_box 0;
-            begin match tyl with
-              [] -> ()
-            | [ty1] ->
-                typexp sch 3 ty1; print_space()
-            | tyl ->
-                open_box 1; print_string "("; typlist sch 0 "," tyl;
-                print_string ")"; close_box(); print_space()
-            end;
-            if not all_present then
-              if sch && px.level <> generic_level then print_string "_#"
-              else print_char '#';
-            path p;
-            if not all_present && present <> [] then begin
-              open_box 1;
-              print_string "[>";
-              print_list (fun (s,_) -> print_char '`'; print_string s)
-                print_space present;
-              print_char ']';
-              close_box ()
-            end;
-            close_box ()
+        | Some(p, tyl) when namable_row row ->
+            let sharp_mark =
+              if not all_present then non_gen_mark sch px ^ "#" else "" in
+            let print_present ppf = function
+              | [] -> ()
+              | l ->
+                 if not all_present then fprintf ppf "[>%a]" pr_present l in
+            fprintf ppf "@[%a%s%a%a@]"
+              (typargs sch) tyl sharp_mark path p print_present present
         | _ ->
-            open_hovbox 0;
-            if not (row.row_closed && all_present) && sch &&
-              px.level <> generic_level then print_string "_["
-            else print_char '[';
-            if all_present then begin
-              if row.row_closed then () else
-              if fields = [] then print_string "< .." else
-              print_char '>'
-            end else
-              print_char '<';
-            print_list (row_field sch) (fun () -> printf "@,|") fields;
-            if not (row.row_closed || all_present) then printf "@,| ..";
-            if present <> [] && not all_present then begin
-              print_space ();
-              open_hovbox 2;
-              print_string ">";
-              print_list (fun (s,_) -> print_char '`'; print_string s)
-                print_space present;
-              close_box ()
-            end;
-            print_char ']';
-            close_box ()
+            let gen_mark =
+              if not (row.row_closed && all_present)
+              then non_gen_mark sch px
+              else "" in
+            let close_mark =
+              if not all_present then "<" else
+              if row.row_closed then "" else
+              if fields = [] then "< .." else ">" in
+            let pr_ellipsis ppf =
+              if not (row.row_closed || all_present)
+              then fprintf ppf "@ | .." in
+            let print_present ppf = function
+              | [] -> ()
+              | l ->
+                 if not all_present then fprintf ppf "@ >%a" pr_present l in
+            let print_fields ppf fields =
+              print_list (row_field sch)
+                         (fun () -> fprintf ppf "@ | ") ppf fields in
+              
+            fprintf ppf "@[<hov>%s[%s%a%t%a]@]"
+              gen_mark close_mark print_fields fields
+              pr_ellipsis print_present present
         end
     | Tobject (fi, nm) ->
-        typobject sch ty fi nm
-(*
-| Tfield _ -> typobject sch ty ty (ref None)
-| Tnil -> typobject sch ty ty (ref None)
-*)
+        typobject sch ty fi ppf nm
     | Tsubst ty ->
-        typexp sch prio ty
+        typexp sch prio ppf ty
     | _ ->
         fatal_error "Printtyp.typexp"
-    end;
-    if alias then begin
-      print_string " as ";
-      print_string "'";
-      print_name_of_type px;
-      (* if not (opened_object ty) then
-        remove_name_of_type px; *)
-      if prio0 >= 1 then print_string ")";
-      close_box()
-    end
-  end
-(*; print_string "["; print_int ty.level; print_string "]"*)
-
-and row_field sch (l,f) =
-  open_box 2;
-  print_char '`';
-  print_string l;
-  begin match row_field_repr f with
-    Rpresent None | Reither(true, [], _) -> ()
-  | Rpresent(Some ty) -> print_space (); typexp sch 0 ty
-  | Reither(c, tyl,_) ->
-      print_space ();
-      if c then printf "&@ ";
-      typlist sch 0 " &" tyl
-  | Rabsent -> print_space (); print_string "[]"
-  end;
-  close_box ()
-
-and typlist sch prio sep = function
-    [] -> ()
-  | [ty] -> typexp sch prio ty
-  | ty::tyl ->
-      typexp sch prio ty; print_string sep; print_space();
-      typlist sch prio sep tyl
-
-and typobject sch ty fi nm =
+   ) in
+  if List.memq px !aliased then begin
+    check_name_of_type px;
+    if prio0 >= 1
+    then printf "@[<1>(%a as '%a)@]" pr_typ 0 print_name_of_type px
+    else printf "@[%a as '%a@]" pr_typ prio0 print_name_of_type px end
+  else pr_typ ppf prio0
+
+and row_field sch ppf (l, f) =
+  let pr_field ppf f =
+    match row_field_repr f with
+    | Rpresent None | Reither(true, [], _) -> ()
+    | Rpresent(Some ty) -> fprintf ppf "@ %a" (typexp sch 0) ty
+    | Reither(c, tyl,_) ->
+        if c
+        then fprintf ppf "@ &@ %a" (typlist sch 0 " &") tyl
+        else fprintf ppf "@ %a" (typlist sch 0 " &") tyl
+    | Rabsent -> fprintf ppf "@ []" in
+  fprintf ppf "@[<2>`%s%a@]" l pr_field f
+
+(* typlist is simply 
+   print_list (typexp sch prio) (fun () -> fprintf ppf "%s@ " sep) *)
+and typlist sch prio sep ppf = function
+  | [] -> ()
+  | [ty] -> typexp sch prio ppf ty
+  | ty :: tyl ->
+      fprintf ppf "%a%s@ %a"
+       (typexp sch prio) ty sep (typlist sch prio sep) tyl
+
+and typargs sch ppf = function
+  | [] -> ()
+  | [ty1] -> fprintf ppf "%a@ " (typexp sch 3) ty1
+  | tyl -> fprintf ppf "@[<1>(%a)@]@ " (typlist sch 0 ",") tyl
+
+and typobject sch ty fi ppf nm =
   begin match !nm with
-    None ->
-      open_box 2;
-      print_string "< ";
-      (let (fields, rest) = flatten_fields fi in
-       let present_fields =
-         List.fold_right
-           (fun (n, k, t) l ->
-              match field_kind_repr k with
-                Fpresent ->
-                  (n, t)::l
-              | _ ->
-                  l)
-           fields []
-       in
-       typfields sch rest
-         (Sort.list (fun (n, _) (n', _) -> n <= n') present_fields));
-      print_string " >";
-      close_box ()
-  | Some (p, {desc = Tvar}::tyl) ->
-      open_box 0;
-      begin match tyl with
-        [] -> ()
-      | [ty1] ->
-          typexp sch 3 ty1; print_space()
-      | tyl ->
-          open_box 1; print_string "("; typlist sch 0 "," tyl;
-          print_string ")"; close_box(); print_space()
-      end;
-      if sch & ty.level <> generic_level then
-        print_string "_";
-      print_string "#";
-      path p;
-      close_box()
+  | None ->
+      let pr_fields ppf fi =
+        let (fields, rest) = flatten_fields fi in
+        let present_fields =
+          List.fold_right
+            (fun (n, k, t) l ->
+               match field_kind_repr k with
+               | Fpresent -> (n, t) :: l
+               | _ -> l)
+            fields [] in
+        let sorted_fields =
+          Sort.list (fun (n, _) (n', _) -> n <= n') present_fields in
+        typfields sch rest ppf sorted_fields in
+      fprintf ppf "@[<2>< %a >@]" pr_fields fi
+  | Some (p, {desc = Tvar} :: tyl) ->
+      fprintf ppf "@[%a%s#%a@]" (typargs sch) tyl (non_gen_mark sch ty) path p
   | _ ->
         fatal_error "Printtyp.typobject"
   end
 
-and typfields sch rest =
-  function
-    [] ->
+and non_gen_mark sch ty =
+    if sch && ty.level <> generic_level then "_" else "" 
+
+and typfields sch rest ppf = function
+  | [] ->
       begin match rest.desc with
-        Tvar -> if sch & rest.level <> generic_level then
-                  print_string "_";
-                print_string ".."
+      | Tvar -> fprintf ppf "%s.." (non_gen_mark sch rest)
       | Tnil -> ()
-      | _    -> fatal_error "typfields (1)"
+      | _ -> fatal_error "typfields (1)"
       end
   | [(s, t)] ->
-      print_string s;
-      print_string " : ";
-      typexp sch 0 t;
+      fprintf ppf "%s : %a" s (typexp sch 0) t;
       begin match rest.desc with
-        Tvar -> print_string ";"; print_space ()
+      | Tvar -> fprintf ppf ";@ "
       | Tnil -> ()
-      | _    -> fatal_error "typfields (2)"
+      | _ -> fatal_error "typfields (2)"
       end;
-      typfields sch rest []
-  | (s, t)::l ->
-      print_string s;
-      print_string " : ";
-      typexp sch 0 t;
-      print_string ";"; print_space ();
-      typfields sch rest l
+      typfields sch rest ppf []
+  | (s, t) :: l ->
+      fprintf ppf "%s : %a;@ %a" s (typexp sch 0) t (typfields sch rest) l
 
-let type_expr ty =
-  typexp false 0 ty
+let type_expr ppf ty = typexp false 0 ppf ty
 
-and type_sch ty =
-  typexp true 0 ty
+and type_sch ppf ty = typexp true 0 ppf ty
 
-and type_scheme ty =
-  reset(); mark_loops ty; typexp true 0 ty
+and type_scheme ppf ty = reset_and_mark_loops ty; typexp true 0 ppf ty
 
 (* Print one type declaration *)
 
-let constrain ty =
+let constrain ppf ty =
   let ty' = unalias ty in
-  if ty != ty' then begin
-    print_space ();
-    open_box 2;
-    print_string "constraint ";
-    type_sch ty;
-    print_string " =";
-    print_space();
-    type_sch ty';
-    close_box()
-  end
+  if ty != ty'
+  then fprintf ppf "@ @[<2>constraint %a =@ %a@]" type_sch ty type_sch ty'
+
+let rec type_decl kwd id ppf decl =
 
-let rec type_decl kwd id decl =
   reset();
 
   let params = List.map repr decl.type_params in
@@ -450,127 +373,101 @@ let rec type_decl kwd id decl =
   List.iter mark_loops params;
   List.iter check_name_of_type params;
   begin match decl.type_manifest with
-    None    -> ()
+  | None -> ()
   | Some ty -> mark_loops ty
   end;
   begin match decl.type_kind with
-    Type_abstract -> ()
+  | Type_abstract -> ()
   | Type_variant [] -> ()
   | Type_variant cstrs ->
       List.iter (fun (_, args) -> List.iter mark_loops args) cstrs
-  | Type_record (lbl1 :: lbls as l) ->
+  | Type_record l ->
       List.iter (fun (_, _, ty) -> mark_loops ty) l
-  | _ -> assert false
   end;
 
-  open_hvbox 2;
-  print_string kwd;
-  type_expr (Btype.newgenty (Tconstr(Pident id, params, ref Mnil)));
+  fprintf ppf "@[<hv 2>%s%a"
+    kwd type_expr (Btype.newgenty (Tconstr(Pident id, params, ref Mnil)));
   begin match decl.type_manifest with
-    None -> ()
-  | Some ty ->
-      print_string " ="; print_space(); type_expr ty
+  | None -> ()
+  | Some ty -> fprintf ppf " =@ %a" type_expr ty
   end;
   begin match decl.type_kind with
-    Type_abstract -> ()
+  | Type_abstract -> ()
   | Type_variant [] -> ()
       (* A fatal error actually, except when printing type exn... *)
   | Type_variant cstrs ->
-      printf " ="; print_break 1 2;
-      print_list constructor (fun () -> printf "@ | ") cstrs
+      fprintf ppf " =@;<1 2>%a"
+       (print_list constructor (fun () -> fprintf ppf "@ | "))
+       cstrs
   | Type_record (lbl1 :: lbls as l) ->
-      print_string " ="; print_space();
-      print_string "{ "; label lbl1;
-      List.iter
-        (fun lbl -> print_string ";"; print_break 1 2; label lbl)
-        lbls;
-      print_string " }"
+      let pr_labels ppf lbls =
+        List.iter
+         (fun lbl -> fprintf ppf ";@;<1 2>%a" label lbl)
+         lbls in
+      fprintf ppf " =@ { %a%a }" label lbl1 pr_labels lbls
   | _ -> assert false
   end;
-  List.iter constrain params;
-  close_box()
+  fprintf ppf "%a@]" (fun ppf l -> List.iter (constrain ppf) l) params
 
-and constructor (name, args) =
-  print_string name;
+and constructor ppf (name, args) =
   match args with
-    [] -> ()
-  | _  -> print_string " of ";
-          open_box 2; typlist false 3 " *" args; close_box()
-
-and label (name, mut, arg) =
-  begin match mut with
-      Immutable -> ()
-    | Mutable -> print_string "mutable "
-  end;
-  print_string name;
-  print_string ": ";
-  type_expr arg
+  | [] -> print_string name
+  | _ -> fprintf ppf "%s of @[<2>%a@]" name (typlist false 3 " *") args
+
+and label ppf (name, mut, arg) =
+  fprintf ppf "%s%s: %a" (string_of_mutable mut) name type_expr arg
+
+and string_of_mutable = function
+  | Immutable -> ""
+  | Mutable -> "mutable "
 
 let type_declaration id decl = type_decl "type " id decl
 
 (* Print an exception declaration *)
 
-let exception_declaration id decl =
-  print_string "exception "; constructor (Ident.name id, decl)
+let exception_declaration id ppf decl =
+  fprintf ppf "exception %a" constructor (Ident.name id, decl)
 
 (* Print a value declaration *)
 
-let value_ident id =
+let value_ident ppf id =
   let name = Ident.name id in
-  if List.mem name ["or";"mod";"land";"lor";"lxor";"lsl";"lsr";"asr"] then
-    printf "( %s )" name
+  if List.mem name
+      ["or"; "mod"; "land"; "lor"; "lxor"; "lsl"; "lsr"; "asr"]
+  then fprintf ppf "( %s )" name
   else match name.[0] with
-    'a'..'z'|'\223'..'\246'|'\248'..'\255'|'_' -> ident id
-  | _ -> printf "( %s )" name
-
-let value_description id decl =
-  open_box 2;
-  print_string (if decl.val_kind = Val_reg then "val " else "external ");
-  value_ident id; print_string " :"; print_space();
-  type_scheme decl.val_type;
-  begin match decl.val_kind with
-    Val_prim p ->
-      print_space(); print_string "= "; Primitive.print_description p
-  | _ -> ()
-  end;
-  close_box()
+  | 'a' .. 'z' | '\223' .. '\246' | '\248' .. '\255' | '_' -> ident ppf id
+  | _ -> fprintf ppf "( %s )" name
+
+let value_description id ppf decl =
+  let kwd = if decl.val_kind = Val_reg then "val " else "external " in
+  let pr_val ppf =
+    match decl.val_kind with
+    | Val_prim p ->
+        fprintf ppf "@ = "; Primitive.print_description p
+    | _ -> () in
+  fprintf ppf "@[<2>%s%a :@ %a%t@]"
+    kwd value_ident id type_scheme decl.val_type pr_val
 
 (* Print a class type *)
 
-let class_var sch l (m, t) =
-  print_space ();
-  open_box 2;
-  print_string "val ";
-  begin match m with
-    Immutable -> ()
-  | Mutable -> print_string "mutable "
-  end;
-  print_string l;
-  print_string " :";
-  print_space();
-  typexp sch 0 t;
-  close_box()
+let class_var sch ppf l (m, t) =
+  fprintf ppf
+    "@ @[<2>val %s%s :@ %a@]" (string_of_mutable m) l (typexp sch 0) t
 
-let metho sch concrete (lab, kind, ty) =
+let metho sch concrete ppf (lab, kind, ty) =
   if lab <> "*dummy method*" then begin
-    print_space ();
-    open_box 2;
-    print_string "method ";
-    begin match field_kind_repr kind with
-      Fvar _ (* {contents = None} *) -> print_string "private "
-    | _ (* Fpresent *)               -> ()
-    end;
-    if not (Concr.mem lab concrete) then print_string "virtual ";
-    print_string lab;
-    print_string " :";
-    print_space ();
-    typexp sch 0 ty;
-    close_box ()
+    let priv =
+      match field_kind_repr kind with
+      | Fvar _ (* {contents = None} *) -> "private "
+      | _ (* Fpresent *) -> "" in
+    let virt =
+      if Concr.mem lab concrete then "" else "virtual " in
+    fprintf ppf "@ @[<2>method %s%s%s :@ %a@]" priv virt lab (typexp sch 0) ty
   end
 
-let rec prepare_class_type =
-  function
-    Tcty_constr (p, tyl, cty) ->
+let rec prepare_class_type = function
+  | Tcty_constr (p, tyl, cty) ->
       let sty = Ctype.self_type cty in
       begin try
         if List.memq sty !visited_objects then raise (Unify []);
@@ -591,80 +488,55 @@ let rec prepare_class_type =
         Ctype.flatten_fields (Ctype.object_fields sign.cty_self)
       in
       List.iter (fun (_, _, ty) -> mark_loops ty) fields;
-(*
-      begin match sty.desc with
-        Tobject (fi, _) -> mark_loops fi
-      | _               -> assert false
-      end;
-*)
       Vars.iter (fun _ (_, ty) -> mark_loops ty) sign.cty_vars
   | Tcty_fun (_, ty, cty) ->
       mark_loops ty;
       prepare_class_type cty
 
-let rec perform_class_type sch params =
-  function
-    Tcty_constr (p', tyl, cty) ->
+let rec perform_class_type sch params ppf = function
+  | Tcty_constr (p', tyl, cty) ->
       let sty = Ctype.self_type cty in
       if List.memq sty !visited_objects then
-        perform_class_type sch params cty
-      else begin
-        open_box 0;
-        if tyl <> [] then begin
-          open_box 1;
-          print_string "[";
-          typlist true 0 "," tyl;
-          print_string "]";
-          close_box ();
-          print_space ()
-        end;
-        path p';
-        close_box ()
-      end
+        perform_class_type sch params ppf cty
+      else
+        let pr_tyl ppf = function
+          | [] -> ()
+          | tyl -> fprintf ppf "@[<1>[%a]@]@ " (typlist true 0 ",") tyl in
+        fprintf ppf "@[%a%a@]" pr_tyl tyl path p'
   | Tcty_signature sign ->
       let sty = repr sign.cty_self in
-      open_hvbox 2;
-      open_box 2;
-      print_string "object";
-      if List.memq sty !aliased then begin
-        print_space ();
-        open_box 0;
-        print_string "('";
-        print_name_of_type sty;
-        print_string ")";
-        close_box ()
-      end;
-      close_box ();
-      List.iter constrain params;
-      Vars.iter (class_var sch) sign.cty_vars;
+      let pr_param ppf sty =
+       if List.memq sty !aliased then
+        fprintf ppf "@ @[('%a)@]" print_name_of_type sty in
+
+      fprintf ppf "@[<hv 2>@[<2>object%a@]%a"
+              pr_param sty
+              (fun ppf l -> List.iter (constrain ppf) l) params;
+      Vars.iter (class_var sch ppf) sign.cty_vars;
       let (fields, _) =
-        Ctype.flatten_fields (Ctype.object_fields sign.cty_self)
-      in
-      List.iter (metho sch sign.cty_concr) fields;
-      print_break 1 (-2);
-      print_string "end";
-      close_box()
+        Ctype.flatten_fields (Ctype.object_fields sign.cty_self) in
+      List.iter (metho sch sign.cty_concr ppf) fields;
+      fprintf ppf "@;<1 -2>end@]"
   | Tcty_fun (l, ty, cty) ->
-      open_box 0;
-      print_label l;
-      if is_optional l then
-        match (repr ty).desc with
-          Tconstr(path, [ty], _) when path = Predef.path_option ->
-            typexp sch 2 ty
-        | _ -> assert false
-      else
-        typexp sch 2 ty;
-      print_string " ->";
-      print_space ();
-      perform_class_type sch params cty;
-      close_box ()
-
-let class_type cty =
+      let ty =
+       if is_optional l then
+         match (repr ty).desc with
+         | Tconstr(path, [ty], _) when path = Predef.path_option -> ty
+         | _ -> assert false
+       else ty in
+      fprintf ppf "@[%a%a ->@ %a@]"
+       print_label l (typexp sch 2) ty (perform_class_type sch params) cty
+
+let class_type ppf cty =
   reset ();
   prepare_class_type cty;
-  perform_class_type false [] cty
+  perform_class_type false [] ppf cty
 
-let class_declaration id cl =
+let class_params ppf = function
+  | [] -> ()
+  | params -> fprintf ppf "@[<1>[%a]@]@ " (typlist true 0 ",") params
+
+let class_declaration id ppf cl =
   let params = List.map repr cl.cty_params in
 
   reset ();
@@ -677,28 +549,11 @@ let class_declaration id cl =
   if List.memq sty !aliased then
     check_name_of_type sty;
 
-  open_box 2;
-  print_string "class";
-  print_space ();
-  if cl.cty_new = None then begin
-    print_string "virtual";
-    print_space ()
-  end;
-  if params <> [] then begin
-    open_box 1;
-    print_string "[";
-    typlist true 0 "," params;
-    print_string "]";
-    close_box ();
-    print_space ()
-  end;
-  ident id;
-  print_space ();
-  print_string ":"; print_space ();
-  perform_class_type true params cl.cty_type;
-  close_box ()
+  let vir_mark = if cl.cty_new = None then " virtual" else "" in
+  fprintf ppf "@[<2>class%s@ %a%a@ :@ %a@]" vir_mark
+    class_params params ident id (perform_class_type true params) cl.cty_type
 
-let cltype_declaration id cl =
+let cltype_declaration id ppf cl =
   let params = List.map repr cl.clty_params in
 
   reset ();
@@ -712,236 +567,176 @@ let cltype_declaration id cl =
     check_name_of_type sty;
 
   let sign = Ctype.signature_of_class_type cl.clty_type in
+
   let virt =
     let (fields, _) =
-      Ctype.flatten_fields (Ctype.object_fields sign.cty_self)
-    in
+      Ctype.flatten_fields (Ctype.object_fields sign.cty_self) in
     List.exists
       (fun (lab, _, ty) ->
-         not ((lab = "*dummy method*")
-                         ||
-              (Concr.mem lab sign.cty_concr)))
-      fields
-  in
-
-  open_box 2;
-  print_string "class type";
-  print_space ();
-  if virt then begin
-    print_string "virtual";
-    print_space ()
-  end;
-  if params <> [] then begin
-    open_box 1;
-    print_string "[";
-    typlist true 0 "," params;
-    print_string "]";
-    close_box ();
-    print_space ()
-  end;
-  ident id;
-  print_space ();
-  print_string "=";
-  print_space ();
-  perform_class_type true params cl.clty_type;
-  close_box ()
+         not (lab = "*dummy method*" || Concr.mem lab sign.cty_concr))
+      fields in
+
+  let vir_mark = if virt then " virtual" else "" in
+  fprintf ppf "@[<2>class type%s@ %a%a@ =@ %a@]"
+   vir_mark class_params params 
+   ident id
+   (perform_class_type true params) cl.clty_type
 
 (* Print a module type *)
 
-let rec modtype = function
-    Tmty_ident p ->
-      path p
+let rec modtype ppf = function
+  | Tmty_ident p ->
+      path ppf p
   | Tmty_signature sg ->
-      open_hvbox 2;
-      print_string "sig"; signature_body true sg; 
-      print_break 1 (-2); print_string "end";
-      close_box()
+      fprintf ppf "@[<hv 2>sig%a@;<1 -2>end@]" (signature_body true) sg
   | Tmty_functor(param, ty_arg, ty_res) ->
-      open_box 2;
-      print_string "functor"; print_cut();
-      print_string "("; ident param; print_string " : ";
-      modtype ty_arg;
-      print_string ") ->"; print_space();
-      modtype ty_res;
-      close_box()
-
-and signature_body spc = function
-    [] -> ()
+      fprintf ppf "@[<2>functor@ (%a : %a) ->@ %a@]"
+       ident param modtype ty_arg modtype ty_res
+
+and signature_body spc ppf = function
+  | [] -> ()
   | item :: rem ->
       if spc then print_space();
       let cont =
         match item with
-          Tsig_value(id, decl) ->
-            value_description id decl; rem
+        | Tsig_value(id, decl) ->
+            value_description id ppf decl; rem
         | Tsig_type(id, decl)  ->
-            type_declaration id decl;
+            type_declaration id ppf decl;
             let rec more_type_declarations = function
-              Tsig_type(id, decl) :: rem ->
-                print_space();
-                type_decl "and " id decl;
+            | Tsig_type(id, decl) :: rem ->
+                fprintf ppf "@ %a" (type_decl "and " id) decl;
                 more_type_declarations rem
             | rem -> rem in
             more_type_declarations rem
         | Tsig_exception(id, decl)  ->
-            exception_declaration id decl; rem
+            exception_declaration id ppf decl; rem
         | Tsig_module(id, mty)  ->
-            open_box 2; print_string "module "; ident id; print_string " :";
-            print_space(); modtype mty; close_box(); rem
+            fprintf ppf "@[<2>module %a :@ %a@]" ident id modtype mty; rem
         | Tsig_modtype(id, decl)  ->
-            modtype_declaration id decl; rem
+            modtype_declaration id ppf decl; rem
         | Tsig_class(id, decl) ->
-            class_declaration id decl;
+            class_declaration id ppf decl;
             begin match rem with
-              ctydecl::tydecl1::tydecl2::rem -> rem | _ -> []
+            | ctydecl :: tydecl1 :: tydecl2 :: rem -> rem
+            | _ -> []
             end
         | Tsig_cltype(id, decl) ->
-            cltype_declaration id decl;
-            match rem with tydecl1::tydecl2::rem -> rem | _ -> []
-      in signature_body true cont
-
-and modtype_declaration id decl =
-  open_box 2; print_string "module type "; ident id;
-  begin match decl with
-    Tmodtype_abstract -> ()
-  | Tmodtype_manifest mty ->
-      print_string " ="; print_space(); modtype mty
-  end;
-  close_box()
+            cltype_declaration id ppf decl;
+            match rem with tydecl1 :: tydecl2 :: rem -> rem | _ -> []
+      in signature_body true ppf cont
+
+and modtype_declaration id ppf decl =
+  let pr_decl ppf = function
+    | Tmodtype_abstract -> ()
+    | Tmodtype_manifest mty -> fprintf ppf " =@ %a" modtype mty in
+  fprintf ppf "@[<2>module type %a%a" ident id pr_decl decl
 
 (* Print a signature body (used by -i when compiling a .ml) *)
 
-let signature sg =
-  open_vbox 0;
-  signature_body false sg;
-  close_box()
+let signature ppf sg = fprintf ppf "@[<v>%a@]" (signature_body false) sg
 
 (* Print an unification error *)
 
-let type_expansion t t' =
-  if t == t' then
-    type_expr t
-  else begin
-    open_box 2;
-    type_expr t;
-    print_space (); print_string "="; print_space ();
-    type_expr t';
-    close_box ()
-  end
+let type_expansion t ppf t' =
+  if t == t' then type_expr ppf t
+  else fprintf ppf "@[<2>%a@ =@ %a@]" type_expr t type_expr t'
 
-let rec trace fst txt =
-  function
-    (t1, t1')::(t2, t2')::rem ->
-      if not fst then
-        print_cut ();
-      open_box 0;
-      print_string "Type"; print_break 1 2;
-      type_expansion t1 t1'; print_space ();
-      txt (); print_break 1 2;
-      type_expansion t2 t2';
-      close_box ();
-      trace false txt rem
-  | _ ->
-      ()
+let rec trace fst txt ppf = function
+  | (t1, t1') :: (t2, t2') :: rem ->
+      if not fst then fprintf ppf "@,";
+      fprintf ppf "@[Type@;<1 2>%a@ %s@;<1 2>%a@] %a"
+       (type_expansion t1) t1' txt (type_expansion t2) t2'
+       (trace false txt) rem
+  | _ -> ()
 
-let rec mismatch =
-  function
-    [(_, t); (_, t')] -> (t, t')
-  | _ :: _ :: rem     -> mismatch rem
-  | _                 -> assert false
+let rec mismatch = function
+  | [(_, t); (_, t')] -> (t, t')
+  | _ :: _ :: rem -> mismatch rem
+  | _ -> assert false
 
-let rec filter_trace =
-  function
-    (t1, t1')::(t2, t2')::rem ->
+let rec filter_trace = function
+  | (t1, t1') :: (t2, t2') :: rem ->
       let rem' = filter_trace rem in
-      if (t1 == t1') & (t2 == t2')
+      if t1 == t1' && t2 == t2'
       then rem'
-      else (t1, t1')::(t2, t2')::rem'
-  | _ ->
-      []
+      else (t1, t1') :: (t2, t2') :: rem'
+  | _ -> []
 
 (* Hide variant name, to force printing the expanded type *)
 let hide_variant_name t =
   match repr t with
-    {desc = Tvariant row} as t when (row_repr row).row_name <> None ->
+  | {desc = Tvariant row} as t when (row_repr row).row_name <> None ->
       newty2 t.level (Tvariant {(row_repr row) with row_name = None})
-  | _ ->
-      t
+  | _ -> t
 
 let prepare_expansion (t, t') =
   let t' = hide_variant_name t' in
   mark_loops t; if t != t' then mark_loops t';
   (t, t')
 
-let unification_error unif tr txt1 txt2 =
+let unification_error unif tr txt1 ppf txt2 =
   reset ();
   let tr = List.map (fun (t, t') -> (t, hide_variant_name t')) tr in
   let (t3, t4) = mismatch tr in
   match tr with
-    [] | _::[] ->
-      assert false
-  | t1::t2::tr ->
+  | [] | _ :: [] -> assert false
+  | t1 :: t2 :: tr ->
     try
       let t1, t1' = prepare_expansion t1
       and t2, t2' = prepare_expansion t2 in
       print_labels := not !Clflags.classic;
-      open_vbox 0;
       let tr = filter_trace tr in
       let tr = List.map prepare_expansion tr in
-      open_box 0;
-      txt1 (); print_break 1 2;
-      type_expansion t1 t1'; print_space();
-      txt2 (); print_break 1 2;
-      type_expansion t2 t2';
-      close_box();
-      trace false (fun _ -> print_string "is not compatible with type") tr;
-      begin match t3.desc, t4.desc with
-        Tfield _, Tvar | Tvar, Tfield _ ->
-          print_cut ();
-          print_string "Self type cannot escape its class"
-      | Tconstr (p, _, _), Tvar when unif && t4.level < Path.binding_time p ->
-          print_cut ();
-          open_box 0;
-          print_string "The type constructor"; print_break 1 2;
-          path p;
-          print_space (); print_string "would escape its scope";
-          close_box()
-      | Tvar, Tconstr (p, _, _) when unif && t3.level < Path.binding_time p ->
-          print_cut ();
-          open_box 0;
-          print_string "The type constructor"; print_break 1 2;
-          path p;
-          print_space (); print_string "would escape its scope";
-          close_box()
-      | Tfield ("*dummy method*", _, _, _), _
-      | _, Tfield ("*dummy method*", _, _, _) ->
-          print_cut ();
-          print_string "Self type cannot be unified with a closed object type"
-      | Tfield (l, _, _, _), _ ->
-          print_cut ();
-          open_box 0;
-          print_string "Only the first object type has a method ";
-          print_string l;
-          close_box()
-      | _, Tfield (l, _, _, _) ->
-          print_cut ();
-          open_box 0;
-          print_string "Only the second object type has a method ";
-          print_string l;
-          close_box()
-      | _ ->
-          ()
-      end;
-      close_box ();
+      let explanation ppf =
+        match t3.desc, t4.desc with
+        | Tfield _, Tvar | Tvar, Tfield _ ->
+            fprintf ppf "@,Self type cannot escape its class"
+        | Tconstr (p, _, _), Tvar
+            when unif && t4.level < Path.binding_time p ->
+            fprintf ppf
+              "@,@[The type constructor@;<1 2>%a@ would escape its scope@]"
+              path p
+        | Tvar, Tconstr (p, _, _)
+            when unif && t3.level < Path.binding_time p ->
+            fprintf ppf
+              "@,@[The type constructor@;<1 2>%a@ would escape its scope@]"
+              path p
+        | Tfield ("*dummy method*", _, _, _), _
+        | _, Tfield ("*dummy method*", _, _, _) ->
+            fprintf ppf
+              "@,Self type cannot be unified with a closed object type"
+        | Tfield (l, _, _, _), _ ->
+            fprintf ppf
+              "@,@[Only the first object type has a method %s@]" l
+        | _, Tfield (l, _, _, _) ->
+            fprintf ppf
+              "@,@[Only the second object type has a method %s@]" l
+        | _ -> () in
+      fprintf ppf
+        "@[<v>\
+          @[%t@;<1 2>%a@ \
+            %t@;<1 2>%a\
+          @]%a%t\
+         @]"
+        txt1 (type_expansion t1) t1'
+        txt2 (type_expansion t2) t2'
+        (trace false "is not compatible with type") tr
+        explanation;
       print_labels := true
     with exn ->
       print_labels := true;
       raise exn
 
-let trace fst txt tr =
+let report_unification_error ppf tr txt1 txt2 =
+  unification_error true tr txt1 ppf txt2;;
+
+let trace fst txt ppf tr =
   print_labels := not !Clflags.classic;
   try
-    trace fst txt (filter_trace tr);
+    trace fst txt ppf (filter_trace tr);
     print_labels := true
   with exn ->
     print_labels := true;
     raise exn
+
diff --git a/typing/printtyp.mli b/typing/printtyp.mli
index 80daa2d9e..bd52d2c98 100644
--- a/typing/printtyp.mli
+++ b/typing/printtyp.mli
@@ -14,29 +14,36 @@
 
 (* Printing functions *)
 
+open Format
 open Types
 
-val longident: Longident.t -> unit
-val ident: Ident.t -> unit
-val path: Path.t -> unit
+val longident: formatter -> Longident.t -> unit
+val ident: formatter -> Ident.t -> unit
+val path: formatter -> Path.t -> unit
 val reset: unit -> unit
 val mark_loops: type_expr -> unit
-val type_expr: type_expr -> unit
-val type_scheme: type_expr -> unit
-val value_description: Ident.t -> value_description -> unit
-val type_declaration: Ident.t -> type_declaration -> unit
-val exception_declaration: Ident.t -> exception_declaration -> unit
-val modtype: module_type -> unit
-val signature: signature -> unit
-val signature_body: bool -> signature -> unit
-val modtype_declaration: Ident.t -> modtype_declaration -> unit
-val class_type: class_type -> unit
-val class_declaration: Ident.t -> class_declaration -> unit
-val cltype_declaration: Ident.t -> cltype_declaration -> unit
-val type_expansion: type_expr -> type_expr -> unit
+val reset_and_mark_loops: type_expr -> unit
+val reset_and_mark_loops_list: type_expr list -> unit
+val type_expr: formatter -> type_expr -> unit
+val type_scheme: formatter -> type_expr -> unit
+val value_description: Ident.t -> formatter -> value_description -> unit
+val type_declaration: Ident.t -> formatter -> type_declaration -> unit
+val exception_declaration: Ident.t -> formatter -> exception_declaration -> unit
+val modtype: formatter -> module_type -> unit
+val signature: formatter -> signature -> unit
+val signature_body: bool -> formatter -> signature -> unit
+val modtype_declaration: Ident.t -> formatter -> modtype_declaration -> unit
+val class_type: formatter -> class_type -> unit
+val class_declaration: Ident.t -> formatter -> class_declaration -> unit
+val cltype_declaration: Ident.t -> formatter -> cltype_declaration -> unit
+val type_expansion: type_expr -> Format.formatter -> type_expr -> unit
 val prepare_expansion: type_expr * type_expr -> type_expr * type_expr
-val trace: bool -> (unit -> unit) -> (type_expr * type_expr) list -> unit
+val trace: bool -> string -> formatter -> (type_expr * type_expr) list -> unit
 val unification_error:
-        bool -> (type_expr * type_expr) list ->
-        (unit -> unit) -> (unit -> unit) ->
-        unit
+    bool -> (type_expr * type_expr) list ->
+    (formatter -> unit) -> formatter -> (formatter -> unit) ->
+    unit
+val report_unification_error:
+    formatter -> (type_expr * type_expr) list ->
+    (formatter -> unit) -> (formatter -> unit) ->
+    unit
diff --git a/typing/typeclass.ml b/typing/typeclass.ml
index b9a9c9d63..663b16b8d 100644
--- a/typing/typeclass.ml
+++ b/typing/typeclass.ml
@@ -19,6 +19,7 @@ open Types
 open Typedtree
 open Typecore
 open Typetexp
+open Format
 
 type error =
     Unconsistent_constraint of (type_expr * type_expr) list
@@ -40,7 +41,7 @@ type error =
   | Bad_parameters of Ident.t * type_expr * type_expr
   | Class_match_failure of Ctype.class_match_failure list
   | Unbound_val of string
-  | Unbound_type_var of (unit -> unit) * Ctype.closed_class_failure
+  | Unbound_type_var of (formatter -> unit) * Ctype.closed_class_failure
   | Make_nongen_seltype of type_expr
   | Non_generalizable_class of Ident.t * Types.class_declaration
 
@@ -212,7 +213,7 @@ let inheritance impl self_type env concr_meths loc parent =
       if impl then begin
         let overridings = Concr.inter cl_sig.cty_concr concr_meths in
         if not (Concr.is_empty overridings) then begin
-          Location.print_warning loc
+          Location.prerr_warning loc
             (Warnings.Method_override (Concr.elements overridings))
         end
       end;
@@ -367,7 +368,7 @@ let rec class_field cl_num self_type meths vars
                enter_val cl_num vars lab mut ty val_env met_env par_env
              in
              if StringSet.mem lab inh_vals then
-               Location.print_warning sparent.pcl_loc
+               Location.prerr_warning sparent.pcl_loc
                  (Warnings.Hide_instance_variable lab);
              (val_env, met_env, par_env, (lab, id) :: inh_vars,
               StringSet.add lab inh_vals))
@@ -396,7 +397,7 @@ let rec class_field cl_num self_type meths vars
 
   | Pcf_val (lab, mut, sexp, loc) ->
       if StringSet.mem lab inh_vals then
-        Location.print_warning loc (Warnings.Hide_instance_variable lab);
+        Location.prerr_warning loc (Warnings.Hide_instance_variable lab);
       let exp =
         try type_exp val_env sexp with Ctype.Unify [(ty, _)] ->
           raise(Error(loc, Make_nongen_seltype ty))
@@ -611,7 +612,7 @@ and class_expr cl_num val_env met_env scl =
       let cl = class_expr cl_num val_env met_env scl' in
       Ctype.end_def ();
       if Btype.is_optional l && all_labeled cl.cl_type then
-        Location.print_warning pat.pat_loc
+        Location.prerr_warning pat.pat_loc
           (Warnings.Other "This optional argument cannot be erased");
       {cl_desc = Tclass_fun (pat, pv, cl, partial);
        cl_loc = scl.pcl_loc;
@@ -980,8 +981,9 @@ let final_env define_class
     None        -> ()
   | Some reason ->
       let printer =
-        if define_class then fun () -> Printtyp.class_declaration id clty
-        else fun () -> Printtyp.cltype_declaration id cltydef
+        if define_class
+        then function ppf -> Printtyp.class_declaration id ppf clty
+        else function ppf -> Printtyp.cltype_declaration id ppf cltydef
       in
       raise(Error(cl.pci_loc, Unbound_type_var(printer, reason)))
   end;
@@ -1052,182 +1054,126 @@ let class_type_declarations env cls =
 
 (* Error report *)
 
-open Formatmsg
+open Format
 
-let report_error = function
+let report_error ppf = function
   | Repeated_parameter ->
-      print_string "A type parameter occurs several times"
+      fprintf ppf "A type parameter occurs several times"
   | Unconsistent_constraint trace ->
-      Printtyp.unification_error true trace
-        (function () ->
-           print_string "The class constraints are not consistent : type")
-        (function () ->
-           print_string "is not compatible with type")
+      Printtyp.report_unification_error ppf trace
+        (function ppf ->
+           fprintf ppf "The class constraints are not consistent : type")
+        (function ppf ->
+           fprintf ppf "is not compatible with type")
   | Method_type_mismatch (m, trace) ->
-      Printtyp.unification_error true trace
-        (function () ->
-           print_string "The method ";
-           print_string m; print_space ();
-           print_string "has type")
-        (function () ->
-           print_string "but is expected to have type")
+      Printtyp.report_unification_error ppf trace
+        (function ppf ->
+           fprintf ppf "The method %s@ has type" m)
+        (function ppf ->
+           fprintf ppf "but is expected to have type")
   | Structure_expected clty ->
-      open_box 0;
-      print_string
-        "This class expression is not a class structure; it has type";
-      print_space();
-      Printtyp.class_type clty;
-      close_box()
+      fprintf ppf
+        "@[This class expression is not a class structure; it has type@ %a@]"
+        Printtyp.class_type clty
   | Cannot_apply clty ->
-      print_string
+      fprintf ppf
         "This class expression is not a class function, it cannot be applied"
   | Apply_wrong_label l ->
-      if l = "" then
-        print_string "This argument cannot be applied without label"
-      else
-        printf "This argument cannot be applied with label %s:" l
+      let mark_label = function
+        | "" -> "out label"
+        |  l -> sprintf " label %s:" l in
+      fprintf ppf "This argument cannot be applied with%s" (mark_label l)
   | Pattern_type_clash ty ->
       (* XXX Trace *)
       (* XXX Revoir message d'erreur *)
-      open_box 0;
-      print_string "This pattern cannot match self: \
-                    it only matches values of type";
-      print_space ();
-      Printtyp.type_expr ty;
-      close_box ()
+      fprintf ppf "@[This pattern cannot match self: \
+                    it only matches values of type@ %a@]"
+      Printtyp.type_expr ty
   | Unbound_class cl ->
-      print_string "Unbound class"; print_space ();
+      fprintf ppf "Unbound class@ %a"
       Printtyp.longident cl
   | Unbound_class_2 cl ->
-      print_string "The class"; print_space ();
-      Printtyp.longident cl; print_space ();
-      print_string "is not yet completely defined"
+      fprintf ppf "The class@ %a@ is not yet completely defined"
+      Printtyp.longident cl
   | Unbound_class_type cl ->
-      print_string "Unbound class type"; print_space ();
+      fprintf ppf "Unbound class type@ %a"
       Printtyp.longident cl
   | Unbound_class_type_2 cl ->
-      print_string "The class type"; print_space ();
-      Printtyp.longident cl; print_space ();
-      print_string "is not yet completely defined"
+      fprintf ppf "The class type@ %a@ is not yet completely defined"
+      Printtyp.longident cl
   | Abbrev_type_clash (abbrev, actual, expected) ->
       (* XXX Afficher une trace ? *)
-      open_box 0;
-      Printtyp.reset ();
-      Printtyp.mark_loops abbrev; Printtyp.mark_loops actual;
-      Printtyp.mark_loops expected;
-      print_string "The abbreviation"; print_space ();
-      Printtyp.type_expr abbrev; print_space ();
-      print_string "expands to type"; print_space ();
-      Printtyp.type_expr actual; print_space ();
-      print_string "but is used with type"; print_space ();
-      Printtyp.type_expr expected;
-      close_box ()
+      Printtyp.reset_and_mark_loops_list [abbrev; actual; expected];
+      fprintf ppf "@[The abbreviation@ %a@ expands to type@ %a@ \
+       but is used with type@ %a@]"
+       Printtyp.type_expr abbrev
+       Printtyp.type_expr actual
+       Printtyp.type_expr expected
   | Constructor_type_mismatch (c, trace) ->
-      Printtyp.unification_error true trace
-        (function () ->
-           print_string "The expression \"new ";
-           print_string c;
-           print_string "\" has type")
-        (function () ->
-           print_string "but is used with type")
+      Printtyp.report_unification_error ppf trace
+        (function ppf ->
+           fprintf ppf "The expression \"new %s\" has type" c)
+        (function ppf ->
+           fprintf ppf "but is used with type")
   | Virtual_class (cl, mets) ->
-      open_vbox 0;
-      if cl then
-        print_string "This class should be virtual"
-      else
-        print_string "This class type should be virtual";
-      print_space ();
-      open_box 2;
-      print_string "The following methods are undefined :";
-      List.iter
-        (function met ->
-          print_space (); print_string met)
-        mets;
-      close_box (); close_box()
+      let print_mets ppf mets =
+        List.iter (function met -> fprintf ppf "@ %s" met) mets in
+      let cl_mark = if cl then " type" else "" in
+      fprintf ppf
+        "@[This class %s should be virtual@ \
+           @[<2>The following methods are undefined :%a@]
+         @]"
+        cl_mark print_mets mets
   | Parameter_arity_mismatch(lid, expected, provided) ->
-      open_box 0;
-      print_string "The class constructor "; Printtyp.longident lid;
-      print_space(); print_string "expects "; print_int expected;
-      print_string " type argument(s),"; print_space();
-      print_string "but is here applied to "; print_int provided;
-      print_string " type argument(s)";
-      close_box()
+      fprintf ppf
+        "@[The class constructor %a@ expects %i type argument(s),@ \
+           but is here applied to %i type argument(s)@]"
+        Printtyp.longident lid expected provided
   | Parameter_mismatch trace ->
-      Printtyp.unification_error true trace
-        (function () ->
-           print_string "The type parameter")
-        (function () ->
-           print_string "does not meet its constraint: it should be")
+      Printtyp.report_unification_error ppf trace
+        (function ppf ->
+           fprintf ppf "The type parameter")
+        (function ppf ->
+           fprintf ppf "does not meet its constraint: it should be")
   | Bad_parameters (id, params, cstrs) ->
-      open_box 0;
-      Printtyp.reset ();
-      Printtyp.mark_loops params; Printtyp.mark_loops cstrs;
-      print_string "The abbreviation"; print_space ();
-      Printtyp.ident id; print_space ();
-      print_string "is used with parameters"; print_space ();
-      Printtyp.type_expr params; print_space ();
-      print_string "wich are incompatible with constraints"; print_space ();
-      Printtyp.type_expr cstrs; print_space ();
-      close_box ()
+      Printtyp.reset_and_mark_loops_list [params; cstrs];
+      fprintf ppf
+        "@[The abbreviation %a@ is used with parameters@ %a@ \
+           wich are incompatible with constraints@ %a@]"
+        Printtyp.ident id Printtyp.type_expr params Printtyp.type_expr cstrs
   | Class_match_failure error ->
-      Includeclass.report_error error
+      Includeclass.report_error ppf error
   | Unbound_val lab ->
-      print_string "Unbound instance variable "; print_string lab
+      fprintf ppf "Unbound instance variable %s" lab
   | Unbound_type_var (printer, reason) ->
-      Printtyp.reset ();
-      open_vbox 0;
-      open_box 0;
-      print_string "Some type variables are unbound in this type:";
-      print_break 1 2;
-      printer ();
-      close_box ();
-      print_space ();
-      open_box 0;
-      begin match reason with
-        Ctype.CC_Method (ty0, real, lab, ty) ->
-          Printtyp.reset ();
-          Printtyp.mark_loops ty; Printtyp.mark_loops ty0;
-          print_string "The method"; print_space ();
-          print_string lab; print_space ();
-          print_string "has type"; print_break 1 2;
-          Printtyp.type_expr ty; print_space ();
-          print_string "where"; print_space ();
-          if real then begin
-            Printtyp.type_expr ty0; print_space ()
-          end else begin
-            print_string ".."; print_space ()
-          end;
-          print_string "is unbound"
+      let print_labty real ppf ty =
+        if real then Printtyp.type_expr ppf ty else fprintf ppf ".." in
+      let print_reason ppf = function
+      | Ctype.CC_Method (ty0, real, lab, ty) ->
+          Printtyp.reset_and_mark_loops_list [ty; ty0];
+          fprintf ppf
+            "The method %s@ has type@;<1 2>%a@ where@ %a@ is unbound"
+            lab Printtyp.type_expr ty (print_labty real) ty0
       | Ctype.CC_Value (ty0, real, lab, ty) ->
-          Printtyp.reset ();
-          Printtyp.mark_loops ty; Printtyp.mark_loops ty0;
-          print_string "The instance variable"; print_space ();
-          print_string lab; print_space ();
-          print_string "has type"; print_break 1 2;
-          Printtyp.type_expr ty; print_space ();
-          print_string "where"; print_space ();
-          if real then begin
-            Printtyp.type_expr ty0; print_space ()
-          end else begin
-            print_string ".."; print_space ()
-          end;
-          print_string "is unbound"
-      end;
-      close_box ();
-      close_box ()
+          Printtyp.reset_and_mark_loops_list [ty; ty0];
+          fprintf ppf
+            "The instance variable %s@ has type@;<1 2>%a@ \
+             where@ %a@ is unbound"
+            lab Printtyp.type_expr ty (print_labty real) ty0
+      in
+      Printtyp.reset ();
+      fprintf ppf
+        "@[<v>@[Some type variables are unbound in this type:@;<1 2>%t@]@ \
+              @[%a@]@]"
+       printer print_reason reason
   | Make_nongen_seltype ty ->
-      open_vbox 0;
-      open_box 0;
-      print_string "Self type should not occur in the non-generic type";
-      print_break 1 2;
-      Printtyp.type_scheme ty;
-      close_box ();
-      print_cut ();
-      print_string "It would escape the scope of its class";
-      close_box ()
+      fprintf ppf
+        "@[<v>@[Self type should not occur in the non-generic type@;<1 2>\
+                %a@]@,\
+           It would escape the scope of its class@]"
+        Printtyp.type_scheme ty
   | Non_generalizable_class (id, clty) ->
-      open_box 0;
-      print_string "The type of this class,"; print_space();
-      Printtyp.class_declaration id clty; print_string ","; print_space();
-      print_string "contains type variables that cannot be generalized";
-      close_box()
+      fprintf ppf
+        "@[The type of this class,@ %a,@ \
+           contains type variables that cannot be generalized@]"
+        (Printtyp.class_declaration id) clty
diff --git a/typing/typeclass.mli b/typing/typeclass.mli
index de5e92bd1..bee4b21e1 100644
--- a/typing/typeclass.mli
+++ b/typing/typeclass.mli
@@ -15,6 +15,7 @@
 open Asttypes
 open Types
 open Typedtree
+open Format
 
 val class_declarations:
   Env.t -> Parsetree.class_declaration list ->
@@ -58,10 +59,10 @@ type error =
   | Bad_parameters of Ident.t * type_expr * type_expr
   | Class_match_failure of Ctype.class_match_failure list
   | Unbound_val of string
-  | Unbound_type_var of (unit -> unit) * Ctype.closed_class_failure
+  | Unbound_type_var of (formatter -> unit) * Ctype.closed_class_failure
   | Make_nongen_seltype of type_expr
   | Non_generalizable_class of Ident.t * Types.class_declaration
 
 exception Error of Location.t * error
 
-val report_error : error -> unit
+val report_error : formatter -> error -> unit
diff --git a/typing/typecore.ml b/typing/typecore.ml
index a8b92a252..f6df2f25b 100644
--- a/typing/typecore.ml
+++ b/typing/typecore.ml
@@ -1023,7 +1023,7 @@ and type_application env funct sargs =
       let exp = type_expect env sarg ty_arg in
       begin match expand_head env exp.exp_type with
       | {desc=Tarrow(_, _, _)} ->
-          Location.print_warning exp.exp_loc Warnings.Partial_application
+          Location.prerr_warning exp.exp_loc Warnings.Partial_application
       | _ -> ()
       end;
       ([Some exp], ty_res)
@@ -1139,7 +1139,7 @@ and type_expect env sexp ty_expected =
         | _ -> true
       in
       if is_optional l && all_labeled ty_res then
-        Location.print_warning (fst (List.hd cases)).pat_loc
+        Location.prerr_warning (fst (List.hd cases)).pat_loc
           (Warnings.Other "This optional argument cannot be erased");
       Parmatch.check_unused env cases;
       let partial = Parmatch.check_partial env sexp.pexp_loc cases in
@@ -1158,12 +1158,12 @@ and type_statement env sexp =
     let exp = type_exp env sexp in
     match (expand_head env exp.exp_type).desc with
     | Tarrow(_, _, _) ->
-        Location.print_warning sexp.pexp_loc Warnings.Partial_application;
+        Location.prerr_warning sexp.pexp_loc Warnings.Partial_application;
         exp
     | Tconstr (p, _, _) when Path.same p Predef.path_unit -> exp
     | Tvar -> exp
     | _ ->
-        Location.print_warning sexp.pexp_loc Warnings.Statement_type;
+        Location.prerr_warning sexp.pexp_loc Warnings.Statement_type;
         exp
 
 (* Typing of match cases *)
@@ -1227,154 +1227,124 @@ let type_expression env sexp =
 
 (* Error report *)
 
-open Formatmsg
+open Format
 open Printtyp
 
-let report_error = function
-    Unbound_value lid ->
-      print_string "Unbound value "; longident lid
+let report_error ppf = function
+  | Unbound_value lid ->
+      fprintf ppf "Unbound value %a" longident lid
   | Unbound_constructor lid ->
-      print_string "Unbound constructor "; longident lid
+      fprintf ppf "Unbound constructor %a" longident lid
   | Unbound_label lid ->
-      print_string "Unbound label "; longident lid
+      fprintf ppf "Unbound label %a" longident lid
   | Constructor_arity_mismatch(lid, expected, provided) ->
-      open_box 0;
-      print_string "The constructor "; longident lid;
-      print_space(); print_string "expects "; print_int expected;
-      print_string " argument(s),"; print_space();
-      print_string "but is here applied to "; print_int provided;
-      print_string " argument(s)";
-      close_box()
+      fprintf ppf
+       "@[The constructor %a@ expects %i argument(s),@ \
+        but is here applied to %i argument(s)@]"
+       longident lid expected provided
   | Label_mismatch(lid, trace) ->
-      unification_error true trace
-        (function () ->
-           print_string "The label "; longident lid;
-           print_space(); print_string "belongs to the type")
-        (function () ->
-           print_string "but is here mixed with labels of type")
+      report_unification_error ppf trace
+        (function ppf ->
+           fprintf ppf "The label %a@ belongs to the type" longident lid)
+        (function ppf ->
+           fprintf ppf "but is here mixed with labels of type")
   | Pattern_type_clash trace ->
-      unification_error true trace
-        (function () ->
-           print_string "This pattern matches values of type")
-        (function () ->
-           print_string "but is here used to match values of type")
+      report_unification_error ppf trace
+        (function ppf ->
+           fprintf ppf "This pattern matches values of type")
+        (function ppf ->
+           fprintf ppf "but is here used to match values of type")
   | Multiply_bound_variable ->
-      print_string "This variable is bound several times in this matching"
+      fprintf ppf "This variable is bound several times in this matching"
   | Orpat_not_closed ->
-      print_string "A pattern with | must not bind variables"
+      fprintf ppf "A pattern with | must not bind variables"
   | Expr_type_clash trace ->
-      unification_error true trace
-        (function () ->
-           print_string "This expression has type")
-        (function () ->
-           print_string "but is here used with type")
+      report_unification_error ppf trace
+        (function ppf ->
+           fprintf ppf "This expression has type")
+        (function ppf ->
+           fprintf ppf "but is here used with type")
   | Apply_non_function typ ->
       begin match (repr typ).desc with
         Tarrow _ ->
-          print_string "This function is applied to too many arguments"
+          fprintf ppf "This function is applied to too many arguments"
       | _ ->
-          print_string
+          fprintf ppf
             "This expression is not a function, it cannot be applied"
       end
   | Apply_wrong_label (l, ty) ->
-      reset (); mark_loops ty;
-      open_vbox 0;
-      open_box 2;
-      print_string "Expecting function has type";
-      print_space ();
-      type_expr ty;
-      close_box ();
-      print_cut ();
-      if l = "" then
-        print_string "This argument cannot be applied without label"
-      else
-        printf "This argument cannot be applied with label %s:" l;
-      close_box ()
+      let print_label ppf = function
+        | "" -> fprintf ppf "out label"
+        | l -> fprintf ppf " label %s:" l in
+      reset_and_mark_loops ty;
+      fprintf ppf
+        "@[<v>@[<2>Expecting function has type@ %a@]@,\
+          This argument cannot be applied with%a@]"
+        type_expr ty print_label l
   | Label_multiply_defined lid ->
-      print_string "The label "; longident lid;
-      print_string " is defined several times"
+      fprintf ppf "The label %a is defined several times" longident lid
   | Label_missing ->
-      print_string "Some labels are undefined"
+      fprintf ppf "Some labels are undefined"
   | Label_not_mutable lid ->
-      print_string "The label "; longident lid;
-      print_string " is not mutable"
+      fprintf ppf "The label %a is not mutable" longident lid
   | Bad_format s ->
-      print_string "Bad format `"; print_string s; print_string "'"
+      fprintf ppf "Bad format `%s'" s
   | Undefined_method (ty, me) ->
-      reset (); mark_loops ty;
-      open_vbox 0;
-      open_box 0;
-      print_string "This expression has type";
-      print_break 1 2;
-      type_expr ty;
-      close_box ();
-      print_cut ();
-      print_string "It has no method ";
-      print_string me;
-      close_box ()
+      reset_and_mark_loops ty;
+      fprintf ppf
+        "@[<v>@[This expression has type@;<1 2>%a@]@,\
+         It has no method %s@]" type_expr ty me
   | Undefined_inherited_method me ->
-      print_string "This expression has no method ";
-      print_string me
+      fprintf ppf "This expression has no method %s" me
   | Unbound_class cl ->
-      print_string "Unbound class "; longident cl
+      fprintf ppf "Unbound class %a" longident cl
   | Virtual_class cl ->
-      print_string "One cannot create instances of the virtual class ";
+      fprintf ppf "One cannot create instances of the virtual class %a"
       longident cl
   | Unbound_instance_variable v ->
-      print_string "Unbound instance variable ";
-      print_string v
+      fprintf ppf "Unbound instance variable %s" v
   | Instance_variable_not_mutable v ->
-      print_string " The instance variable "; print_string v;
-      print_string " is not mutable"
+      fprintf ppf " The instance variable %s is not mutable" v
   | Not_subtype(tr1, tr2) ->
       reset ();
       let tr1 = List.map prepare_expansion tr1
       and tr2 = List.map prepare_expansion tr2 in
-      trace true (fun _ -> print_string "is not a subtype of type") tr1;
-      trace false (fun _ -> print_string "is not compatible with type") tr2
+      trace true "is not a subtype of type" ppf tr1;
+      trace false "is not compatible with type" ppf tr2
   | Outside_class ->
-      print_string "This object duplication occurs outside a method definition"
+      fprintf ppf "This object duplication occurs outside a method definition"
   | Value_multiply_overridden v ->
-      print_string "The instance variable "; print_string v;
-      print_string " is overridden several times"
+      fprintf ppf "The instance variable %s is overridden several times" v
   | Coercion_failure (ty, ty', trace) ->
-      unification_error true trace
-        (function () ->
+      report_unification_error ppf trace
+        (function ppf ->
            let ty, ty' = prepare_expansion (ty, ty') in
-           print_string "This expression cannot be coerced to type";
-           print_break 1 2;
-           type_expansion ty ty';
-           print_string ";";
-           print_space ();
-           print_string "it has type")
-        (function () ->
-           print_string "but is here used with type")
+           fprintf ppf
+             "This expression cannot be coerced to type@;<1 2>%a;@ it has type"
+           (type_expansion ty) ty')
+        (function ppf ->
+           fprintf ppf "but is here used with type")
   | Too_many_arguments ->
-      print_string "This function expects too many arguments"
+      fprintf ppf "This function expects too many arguments"
   | Abstract_wrong_label (l, ty) ->
-      reset (); mark_loops ty;
+      let label_mark = function
+        | "" -> "but its argument is not labeled"
+        |  l -> sprintf "but its argument is labeled %s:" l in
+      reset_and_mark_loops ty;
       open_vbox 0;
       open_box 2;
-      print_string "This function should have type";
-      print_space ();
-      type_expr ty;
-      close_box ();
-      print_cut ();
-      if l = "" then
-        print_string "but its argument is not labeled"
-      else
-        printf "but its argument is labeled %s:" l;
-      close_box ()
+      fprintf ppf "@[<v>@[<2>This function should have type@ %a@]@,%s@]"
+      type_expr ty (label_mark l)
   | Scoping_let_module(id, ty) ->
-      reset (); mark_loops ty;
-      print_string "This `let module' expression has type";
-      print_space(); type_expr ty; print_space();
-      print_string "In this type, the locally bound module name ";
-      print_string id; print_string " escapes its scope"
+      reset_and_mark_loops ty;
+      fprintf ppf
+       "This `let module' expression has type@ %a@ " type_expr ty;
+      fprintf ppf
+       "In this type, the locally bound module name %s escapes its scope" id
   | Masked_instance_variable lid ->
-      print_string "The instance variable "; longident lid; print_space ();
-      print_string
-        "cannot be accessed from the definition of another instance variable"
+      fprintf ppf
+        "The instance variable %a@ \
+         cannot be accessed from the definition of another instance variable"
+        longident lid
   | Not_a_variant_type lid ->
-      print_string "The type "; longident lid; print_space ();
-      print_string "is not a variant type"
+      fprintf ppf "The type %a@ is not a variant type" longident lid
diff --git a/typing/typecore.mli b/typing/typecore.mli
index 66cb5d8f3..14c581fec 100644
--- a/typing/typecore.mli
+++ b/typing/typecore.mli
@@ -16,6 +16,7 @@
 
 open Asttypes
 open Types
+open Format
 
 val is_nonexpansive: Typedtree.expression -> bool
 
@@ -86,7 +87,7 @@ type error =
 
 exception Error of Location.t * error
 
-val report_error: error -> unit
+val report_error: formatter -> error -> unit
 
 (* Forward declaration, to be filled in by Typemod.type_module *)
 val type_module: (Env.t -> Parsetree.module_expr -> Typedtree.module_expr) ref
diff --git a/typing/typedecl.ml b/typing/typedecl.ml
index 3d3bbb5a4..ddc731e53 100644
--- a/typing/typedecl.ml
+++ b/typing/typedecl.ml
@@ -321,36 +321,34 @@ let transl_with_constraint env sdecl =
 
 (**** Error report ****)
 
-open Formatmsg
+open Format
 
-let report_error = function
-    Repeated_parameter ->
-      print_string "A type parameter occurs several times"
+let report_error ppf = function
+  | Repeated_parameter ->
+      fprintf ppf "A type parameter occurs several times"
   | Duplicate_constructor s ->
-      print_string "Two constructors are named "; print_string s
+      fprintf ppf "Two constructors are named %s" s
   | Too_many_constructors ->
-      print_string "Too many constructors -- maximum is ";
-      print_int Config.max_tag; print_string " constructors"
+      fprintf ppf "Too many constructors -- maximum is %i constructors"
+        Config.max_tag
   | Duplicate_label s ->
-      print_string "Two labels are named "; print_string s
+      fprintf ppf "Two labels are named %s" s
   | Recursive_abbrev s ->
-      print_string "The type abbreviation "; print_string s;
-      print_string " is cyclic" (* " expands to itself" *)
+      fprintf ppf "The type abbreviation %s is cyclic" s
   | Definition_mismatch ty ->
-      Printtyp.reset ();
-      Printtyp.mark_loops ty;
-      print_string
-        "The variant or record definition does not match that of type";
-      print_space(); Printtyp.type_expr ty
+      Printtyp.reset_and_mark_loops ty;
+      fprintf ppf
+        "The variant or record definition does not match that of type@ %a"
+        Printtyp.type_expr ty
   | Unconsistent_constraint ->
-      print_string "The type constraints are not consistent"
+      fprintf ppf "The type constraints are not consistent"
   | Type_clash trace ->
-      Printtyp.unification_error true trace
-        (function () ->
-           print_string "This type constructor expands to type")
-        (function () ->
-           print_string "but is here used with type")
+      Printtyp.report_unification_error ppf trace
+        (function ppf ->
+           fprintf ppf "This type constructor expands to type")
+        (function ppf ->
+           fprintf ppf "but is here used with type")
   | Null_arity_external ->
-      print_string "External identifiers must be functions"
+      fprintf ppf "External identifiers must be functions"
   | Unbound_type_var ->
-      print_string "A type variable is unbound in this type declaration";
+      fprintf ppf "A type variable is unbound in this type declaration";;
diff --git a/typing/typedecl.mli b/typing/typedecl.mli
index b9f5b8e1f..c4e2132e4 100644
--- a/typing/typedecl.mli
+++ b/typing/typedecl.mli
@@ -15,6 +15,7 @@
 (* Typing of type definitions and primitive definitions *)
 
 open Types
+open Format
 
 val transl_type_decl:
         Env.t -> (string * Parsetree.type_declaration) list ->
@@ -42,4 +43,4 @@ type error =
 
 exception Error of Location.t * error
 
-val report_error: error -> unit
+val report_error: formatter -> error -> unit
diff --git a/typing/typemod.ml b/typing/typemod.ml
index 981f1b837..eadcda77a 100644
--- a/typing/typemod.ml
+++ b/typing/typemod.ml
@@ -20,7 +20,7 @@ open Path
 open Parsetree
 open Types
 open Typedtree
-
+open Format
 
 type error =
     Unbound_module of Longident.t
@@ -480,10 +480,8 @@ and normalize_signature_item env = function
 
 let type_implementation sourcefile prefixname modulename initial_env ast =
   let (str, sg, finalenv) = type_structure initial_env ast in
-  if !Clflags.print_types then begin
-    Formatmsg.with_output_to Format.std_formatter
-      (fun () -> Printtyp.signature sg; Format.print_newline())
-  end;
+  if !Clflags.print_types then
+    fprintf err_formatter "%a@." Printtyp.signature sg;
   let coercion =
     if Sys.file_exists (prefixname ^ !Config.interface_suffix) then begin
       let intf_file =
@@ -501,77 +499,42 @@ let type_implementation sourcefile prefixname modulename initial_env ast =
 
 (* Error report *)
 
-open Formatmsg
 open Printtyp
 
-let report_error = function
-    Unbound_module lid ->
-      print_string "Unbound module "; longident lid
-  | Unbound_modtype lid ->
-      print_string "Unbound module type "; longident lid
-  | Cannot_apply mty ->
-      open_box 0;
-      print_string "This module is not a functor; it has type";
-      print_space(); modtype mty;
-      close_box()
-  | Not_included errs ->
-      open_vbox 0;
-      print_string "Signature mismatch:"; print_space();
-      Includemod.report_error errs;
-      close_box()
-  | Cannot_eliminate_dependency mty ->
-      open_box 0;
-      print_string "This functor has type";
-      print_space(); modtype mty; print_space();
-      print_string "The parameter cannot be eliminated in the result type.";
-      print_space();
-      print_string "Please bind the argument to a module identifier.";
-      close_box()
-  | Signature_expected ->
-      print_string "This module type is not a signature"
-  | Structure_expected mty ->
-      open_box 0;
-      print_string "This module is not a structure; it has type";
-      print_space(); modtype mty;
-      close_box()
-  | With_no_component lid ->
-      open_box 0;
-      print_string "The signature constrained by `with' has no component named";
-      print_space(); longident lid;
-      close_box()
-  | With_mismatch(lid, explanation) ->
-      open_vbox 0;
-      open_box 0;
-      print_string "In this `with' constraint, the new definition of";
-      print_space(); longident lid; print_space();
-      print_string "does not match its original definition";
-      print_space(); print_string "in the constrained signature:";
-      close_box();
-      print_space();
-      Includemod.report_error explanation;
-      close_box()
-  | Repeated_name(kind, name) ->
-      open_box 0;
-      print_string "Multiple definition of the "; print_string kind;
-      print_string " name "; print_string name; print_string ".";
-      print_space();
-      print_string "Names must be unique in a given structure or signature.";
-      close_box()
-  | Non_generalizable typ ->
-      open_box 0;
-      print_string "The type of this expression,"; print_space();
-      type_scheme typ; print_string ","; print_space();
-      print_string "contains type variables that cannot be generalized";
-      close_box()
-  | Non_generalizable_class (id, desc) ->
-      open_box 0;
-      print_string "The type of this class,"; print_space();
-      class_declaration id desc; print_string ","; print_space();
-      print_string "contains type variables that cannot be generalized";
-      close_box()
-  | Non_generalizable_module mty ->
-      open_box 0;
-      print_string "The type of this module,"; print_space();
-      modtype mty; print_string ","; print_space();
-      print_string "contains type variables that cannot be generalized";
-      close_box()
+let report_error ppf = function
+  | Unbound_module lid -> fprintf ppf "Unbound module %a" longident lid
+  | Unbound_modtype lid -> fprintf ppf "Unbound module type %a" longident lid
+  | Cannot_apply mty -> fprintf ppf
+      "@[This module is not a functor; it has type@ %a@]" modtype mty
+  | Not_included errs -> fprintf ppf
+      "@[<v>Signature mismatch:@ %a]" Includemod.report_error errs
+  | Cannot_eliminate_dependency mty -> fprintf ppf
+      "@[This functor has type@ %a@ \
+         The parameter cannot be eliminated in the result type.@  \
+         Please bind the argument to a module identifier.@]" modtype mty
+  | Signature_expected -> fprintf ppf "This module type is not a signature"
+  | Structure_expected mty -> fprintf ppf
+      "@[This module is not a structure; it has type@ %a" modtype mty
+  | With_no_component lid -> fprintf ppf
+      "@[The signature constrained by `with' has no component named %a@]"
+      longident lid
+  | With_mismatch(lid, explanation) -> fprintf ppf
+      "@[<v>
+         @[In this `with' constraint, the new definition of %a@ \
+           does not match its original definition@ \
+           in the constrained signature:@]@ \
+         %a@]"
+      longident lid Includemod.report_error explanation
+  | Repeated_name(kind, name) -> fprintf ppf
+      "@[Multiple definition of the %s name %s.@ \
+         Names must be unique in a given structure or signature.@]" kind name
+  | Non_generalizable typ -> fprintf ppf
+      "@[The type of this expression,@ %a,@ \
+         contains type variables that cannot be generalized@]" type_scheme typ
+  | Non_generalizable_class (id, desc) -> fprintf ppf
+      "@[The type of this class,@ %a,@ \
+         contains type variables that cannot be generalized@]"
+      (class_declaration id) desc
+  | Non_generalizable_module mty -> fprintf ppf
+      "@[The type of this module,@ %a,@ \
+         contains type variables that cannot be generalized@]" modtype mty
diff --git a/typing/typemod.mli b/typing/typemod.mli
index d8662f459..f14a51931 100644
--- a/typing/typemod.mli
+++ b/typing/typemod.mli
@@ -15,6 +15,7 @@
 (* Type-checking of the module language *)
 
 open Types
+open Format
 
 val type_module:
         Env.t -> Parsetree.module_expr -> Typedtree.module_expr
@@ -45,4 +46,4 @@ type error =
 
 exception Error of Location.t * error
 
-val report_error: error -> unit
+val report_error: formatter -> error -> unit
diff --git a/typing/typetexp.ml b/typing/typetexp.ml
index e1cb50df3..6fd71dd7b 100644
--- a/typing/typetexp.ml
+++ b/typing/typetexp.ml
@@ -305,45 +305,44 @@ let transl_type_scheme env styp =
 
 (* Error report *)
 
-open Formatmsg
+open Format
 open Printtyp
 
-let report_error = function
-    Unbound_type_variable name ->
-      print_string "Unbound type parameter "; print_string name
+let report_error ppf = function
+  | Unbound_type_variable name ->
+      fprintf ppf "Unbound type parameter %s" name
   | Unbound_type_constructor lid ->
-      print_string "Unbound type constructor "; longident lid
+      fprintf ppf "Unbound type constructor %a" longident lid
   | Type_arity_mismatch(lid, expected, provided) ->
-      open_box 0;
-      print_string "The type constructor "; longident lid;
-      print_space(); print_string "expects "; print_int expected;
-      print_string " argument(s),"; print_space();
-      print_string "but is here applied to "; print_int provided;
-      print_string " argument(s)";
-      close_box()
+      fprintf ppf
+       "@[The type constructor %a@ expects %i argument(s),@ \
+        but is here applied to %i argument(s)@]"
+       longident lid expected provided
   | Bound_type_variable name ->
-      print_string "Already bound type parameter "; print_string name
+      fprintf ppf "Already bound type parameter %s" name
   | Recursive_type ->
-      print_string "This type is recursive"
+      fprintf ppf "This type is recursive"
   | Unbound_class lid ->
-      print_string "Unbound class "; longident lid
+      fprintf ppf "Unbound class %a" longident lid
   | Unbound_row_variable lid ->
-      print_string "Unbound row variable in #"; longident lid
+      fprintf ppf "Unbound row variable in #%a" longident lid
   | Type_mismatch trace ->
       Printtyp.unification_error true trace
-        (function () ->
-           print_string "This type")
-        (function () ->
-           print_string "should be an instance of type")
+        (function ppf ->
+           fprintf ppf "This type")
+        ppf
+        (function ppf ->
+           fprintf ppf "should be an instance of type")
   | Alias_type_mismatch trace ->
       Printtyp.unification_error true trace
-        (function () ->
-           print_string "This alias is bound to type")
-        (function () ->
-           print_string "but is used as an instance of type")
+        (function ppf ->
+           fprintf ppf "This alias is bound to type")
+        ppf
+        (function ppf ->
+           fprintf ppf "but is used as an instance of type")
   | Present_has_conjunction l ->
-      printf "The present constructor %s has a conjunctive type" l
+      fprintf ppf "The present constructor %s has a conjunctive type" l
   | Present_has_no_type l ->
-      printf "The present constructor %s has no type" l
+      fprintf ppf "The present constructor %s has no type" l
   | Multiple_constructor l ->
-      printf "The variant constructor %s is multiply defined" l
+      fprintf ppf "The variant constructor %s is multiply defined" l
diff --git a/typing/typetexp.mli b/typing/typetexp.mli
index 83791e123..b68de53c2 100644
--- a/typing/typetexp.mli
+++ b/typing/typetexp.mli
@@ -14,6 +14,8 @@
 
 (* Typechecking of type expressions for the core language *)
 
+open Format;;
+
 val transl_simple_type:
         Env.t -> bool -> Parsetree.core_type -> Types.type_expr
 val transl_simple_type_delayed:
@@ -46,4 +48,4 @@ type error =
 
 exception Error of Location.t * error
 
-val report_error: error -> unit
+val report_error: formatter -> error -> unit