Revu les impressions du compilateur

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

1 files changed, 163 insertions, 155 deletions

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