diff options
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 |