diff options
Diffstat (limited to 'bytecomp')
| -rw-r--r-- | bytecomp/bytelibrarian.ml | 10 | ||||
| -rw-r--r-- | bytecomp/bytelibrarian.mli | 4 | ||||
| -rw-r--r-- | bytecomp/bytelink.ml | 18 | ||||
| -rw-r--r-- | bytecomp/bytelink.mli | 4 | ||||
| -rw-r--r-- | bytecomp/printinstr.ml | 151 | ||||
| -rw-r--r-- | bytecomp/printinstr.mli | 6 | ||||
| -rw-r--r-- | bytecomp/printlambda.ml | 318 | ||||
| -rw-r--r-- | bytecomp/printlambda.mli | 6 | ||||
| -rw-r--r-- | bytecomp/symtable.ml | 12 | ||||
| -rw-r--r-- | bytecomp/symtable.mli | 4 | ||||
| -rw-r--r-- | bytecomp/translclass.ml | 9 | ||||
| -rw-r--r-- | bytecomp/translclass.mli | 4 | ||||
| -rw-r--r-- | bytecomp/translcore.ml | 12 | ||||
| -rw-r--r-- | bytecomp/translcore.mli | 4 |
14 files changed, 290 insertions, 272 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 : |