From: Stephane Glondu Date: Tue, 21 Oct 2014 09:38:39 +0000 (+0200) Subject: Imported Upstream version 4.02.1 X-Git-Tag: archive/raspbian/4.08.1-4+rpi1~3^2~63^2~7 X-Git-Url: https://dgit.raspbian.org/?a=commitdiff_plain;h=b92f950defa3bd03db8075caef1d4179447822f4;p=ocaml.git Imported Upstream version 4.02.1 --- diff --git a/.depend b/.depend index 9b6b9ffb..5d95a9bb 100644 --- a/.depend +++ b/.depend @@ -538,20 +538,20 @@ bytecomp/translclass.cmx : typing/types.cmx bytecomp/typeopt.cmx \ typing/path.cmx bytecomp/matching.cmx parsing/location.cmx \ bytecomp/lambda.cmx typing/ident.cmx typing/env.cmx utils/clflags.cmx \ typing/btype.cmx parsing/asttypes.cmi bytecomp/translclass.cmi -bytecomp/translcore.cmo : utils/warnings.cmi typing/types.cmi \ - bytecomp/typeopt.cmi typing/typedtree.cmi bytecomp/translobj.cmi \ - typing/primitive.cmi typing/predef.cmi typing/path.cmi \ - typing/parmatch.cmi utils/misc.cmi bytecomp/matching.cmi \ - parsing/longident.cmi parsing/location.cmi bytecomp/lambda.cmi \ - typing/ident.cmi typing/env.cmi utils/config.cmi utils/clflags.cmi \ - typing/btype.cmi parsing/asttypes.cmi bytecomp/translcore.cmi -bytecomp/translcore.cmx : utils/warnings.cmx typing/types.cmx \ - bytecomp/typeopt.cmx typing/typedtree.cmx bytecomp/translobj.cmx \ - typing/primitive.cmx typing/predef.cmx typing/path.cmx \ - typing/parmatch.cmx utils/misc.cmx bytecomp/matching.cmx \ - parsing/longident.cmx parsing/location.cmx bytecomp/lambda.cmx \ - typing/ident.cmx typing/env.cmx utils/config.cmx utils/clflags.cmx \ - typing/btype.cmx parsing/asttypes.cmi bytecomp/translcore.cmi +bytecomp/translcore.cmo : typing/types.cmi bytecomp/typeopt.cmi \ + typing/typedtree.cmi bytecomp/translobj.cmi typing/primitive.cmi \ + typing/predef.cmi typing/path.cmi typing/parmatch.cmi utils/misc.cmi \ + bytecomp/matching.cmi parsing/longident.cmi parsing/location.cmi \ + bytecomp/lambda.cmi typing/ident.cmi typing/env.cmi utils/config.cmi \ + utils/clflags.cmi typing/btype.cmi parsing/asttypes.cmi \ + bytecomp/translcore.cmi +bytecomp/translcore.cmx : typing/types.cmx bytecomp/typeopt.cmx \ + typing/typedtree.cmx bytecomp/translobj.cmx typing/primitive.cmx \ + typing/predef.cmx typing/path.cmx typing/parmatch.cmx utils/misc.cmx \ + bytecomp/matching.cmx parsing/longident.cmx parsing/location.cmx \ + bytecomp/lambda.cmx typing/ident.cmx typing/env.cmx utils/config.cmx \ + utils/clflags.cmx typing/btype.cmx parsing/asttypes.cmi \ + bytecomp/translcore.cmi bytecomp/translmod.cmo : typing/types.cmi typing/typedtree.cmi \ bytecomp/translobj.cmi bytecomp/translcore.cmi bytecomp/translclass.cmi \ typing/printtyp.cmi typing/primitive.cmi typing/predef.cmi \ @@ -927,12 +927,12 @@ driver/optmain.cmx : utils/warnings.cmx asmcomp/printmach.cmx \ driver/compenv.cmx utils/clflags.cmx asmcomp/asmpackager.cmx \ asmcomp/asmlink.cmx asmcomp/asmlibrarian.cmx asmcomp/arch.cmx \ driver/optmain.cmi -driver/pparse.cmo : parsing/parsetree.cmi parsing/parse.cmi utils/misc.cmi \ - parsing/location.cmi utils/config.cmi utils/clflags.cmi utils/ccomp.cmi \ - parsing/ast_mapper.cmi parsing/ast_helper.cmi driver/pparse.cmi -driver/pparse.cmx : parsing/parsetree.cmi parsing/parse.cmx utils/misc.cmx \ - parsing/location.cmx utils/config.cmx utils/clflags.cmx utils/ccomp.cmx \ - parsing/ast_mapper.cmx parsing/ast_helper.cmx driver/pparse.cmi +driver/pparse.cmo : parsing/parse.cmi utils/misc.cmi parsing/location.cmi \ + utils/config.cmi utils/clflags.cmi utils/ccomp.cmi parsing/ast_mapper.cmi \ + driver/pparse.cmi +driver/pparse.cmx : parsing/parse.cmx utils/misc.cmx parsing/location.cmx \ + utils/config.cmx utils/clflags.cmx utils/ccomp.cmx parsing/ast_mapper.cmx \ + driver/pparse.cmi toplevel/genprintval.cmi : typing/types.cmi typing/path.cmi \ typing/outcometree.cmi typing/env.cmi toplevel/opttopdirs.cmi : parsing/longident.cmi diff --git a/.gitignore b/.gitignore index d36195a2..6c66ecc5 100644 --- a/.gitignore +++ b/.gitignore @@ -414,6 +414,7 @@ /ocamldoc/odoc_text_parser.ml /ocamldoc/odoc_text_parser.mli /ocamldoc/stdlib_man +/ocamldoc/stdlib_html /ocamldoc/*.output /ocamldoc/test_stdlib /ocamldoc/test_latex diff --git a/Changes b/Changes index 55c3b9a8..f1435285 100644 --- a/Changes +++ b/Changes @@ -1,3 +1,71 @@ +OCaml 4.02.1: +------------- +(Changes that can break existing programs are marked with a "*") + +Standard library: +* Add optional argument ?limit to Arg.align. + +- PR#4099: Bug in Makefile.nt: won't stop on error + (George Necula) +- PR#6181: Improve MSVC build + (Chen Gang) +- PR#6207: Configure doesn't detect features correctly on Haiku + (Jessica Hamilton) +- PR#6466: Non-exhaustive matching warning message for open types is confusing + (Peter Zotov) +- PR#6529: fix quadratic-time algorithm in Consistbl.extract. + (Xavier Leroy, Alain Frisch, relase-worthy report by Jacques-Pascal Deplaix) +- PR#6530: Add stack overflow handling for native code (OpenBSD i386 and amd64) + (Cristopher Zimmermann) +- PR#6533: broken semantics of %(%) when substitued by a box + (Benoît Vaugon, report by Boris Yakobowski) +- PR#6534: legacy support for %.10s + (Benoît Vaugon, Gabriel Scherer, report by Nick Chapman) +- PR#6536: better documentation of flag # in format strings + (Damien Doligez, report by Nick Chapman) +- PR#6544: Bytes and CamlinternalFormat missing from threads stdlib.cma + (Christopher Zimmermann) +- PR#6546: -dsource omits parens for `List ((`String "A")::[]) in patterns + (Gabriel Scherer, report by Peter Zotov) +- PR#6547: __MODULE__ aborts the compiler if the module name cannot be inferred + (Jacques Garrigue, report by Kaustuv Chaudhuri) +- PR#6549: Debug section is sometimes not readable when using -pack + (Hugo Heuzard, review by Gabriel Scherer) +- PR#6553: Missing command line options for ocamldoc + (Maxence Guesdon) +- PR#6554: fix race condition when retrieving backtraces + (Jérémie Dimino, Mark Shinwell). +- PR#6557: String.sub throws Invalid_argument("Bytes.sub") + (Damien Doligez, report by Oliver Bandel) +- PR#6562: Fix ocamldebug module source lookup + (Leo White) +- PR#6563: Inclusion of packs failing to run module initializers + (Jacques Garrigue, report by Mark Shinwell) +- PR#6564: infinite loop in Mtype.remove_aliases + (Jacques Garrigue, report by Mark Shinwell) +- PR#6565: compilation fails with Env.Error(_) + (Jacques Garrigue and Mark Shinwell) +- PR#6566: -short-paths and signature inclusion errors + (Jacques Garrigue, report by Mark Shinwell) +- PR#6572: Fatal error with recursive modules + (Jacques Garrigue, report by Quentin Stievenart) +- PR#6578: Recursive module containing alias causes Segmentation fault + (Jacques Garrigue) +- PR#6581: Some bugs in generative functors + (Jacques Garrigue, report by Mark Shinwell) +- PR#6584: ocamldep support for "-open M" + (Gabriel Scherer, review by Damien Doligez, report by Hezekiah M. Carty) +- PR#6588: Code generation errors for ARM + (Mark Shinwell, Xavier Leroy) +- PR#6590: Improve Windows (MSVC and mingw) build + (Chen Gang) +- PR#6599: ocamlbuild: add -bin-annot when using -pack + (Christopher Zimmermann) +- PR#6602: Fatal error when tracing a function with abstract type + (Jacques Garrigue, report by Hugo Herbelin) +- ocamlbuild: add an -ocamlmklib option to change the ocamlmklib command + (Jérôme Vouillon) + OCaml 4.02.0: ------------- @@ -107,7 +175,7 @@ Runtime system: - Fixed bug in native code version of [caml_raise_with_string] that could potentially lead to heap corruption. (Mark Shinwell) -- Blocks initialized by [CAMLlocal*] and [caml_alloc] are now filled with +* Blocks initialized by [CAMLlocal*] and [caml_alloc] are now filled with [Val_unit] rather than zero. (Mark Shinwell) - Fixed a major performance problem on large heaps (~1GB) by making heap diff --git a/Makefile b/Makefile index 733ed99d..6c0e7e64 100644 --- a/Makefile +++ b/Makefile @@ -367,6 +367,13 @@ installoptopt: cd $(INSTALL_COMPLIBDIR) && $(RANLIB) ocamlcommon.a ocamlbytecomp.a \ ocamloptcomp.a +# Run all tests + +tests: opt.opt + cd testsuite; $(MAKE) clean && $(MAKE) all + +# The clean target + clean:: partialclean # Shared parts of the system diff --git a/Makefile.nt b/Makefile.nt index 648c918d..16b53fe2 100644 --- a/Makefile.nt +++ b/Makefile.nt @@ -252,7 +252,9 @@ installbyt: cp expunge $(INSTALL_LIBDIR)/expunge.exe cp toplevel/topdirs.cmi $(INSTALL_LIBDIR) cd tools ; $(MAKEREC) install - for i in $(OTHERLIBRARIES); do $(MAKEREC) -C otherlibs/$$i install; done + for i in $(OTHERLIBRARIES); do \ + $(MAKEREC) -C otherlibs/$$i install || exit $$?; \ + done if test -n "$(WITH_OCAMLDOC)"; then (cd ocamldoc; $(MAKEREC) install); \ else :; fi if test -n "$(WITH_DEBUGGER)"; then (cd debugger; $(MAKEREC) install); \ diff --git a/VERSION b/VERSION index da8c290a..9023b27c 100644 --- a/VERSION +++ b/VERSION @@ -1,4 +1,4 @@ -4.02.0 +4.02.1 # The version string is the first line of this file. # It must be in the format described in stdlib/sys.mli diff --git a/asmcomp/CSEgen.ml b/asmcomp/CSEgen.ml index 8cd23b0a..6571ad53 100644 --- a/asmcomp/CSEgen.ml +++ b/asmcomp/CSEgen.ml @@ -164,8 +164,8 @@ let insert_move srcs dsts i = | l -> (* Parallel move: first copy srcs into tmps one by one, then copy tmps into dsts one by one *) let tmps = Reg.createv_like srcs in - array_fold2 insert_single_move - (array_fold2 insert_single_move i srcs tmps) tmps dsts + let i1 = array_fold2 insert_single_move i tmps dsts in + array_fold2 insert_single_move i1 srcs tmps (* Classification of operations *) diff --git a/asmcomp/arm/proc.ml b/asmcomp/arm/proc.ml index 6b2ba3cf..58bfa427 100644 --- a/asmcomp/arm/proc.ml +++ b/asmcomp/arm/proc.ml @@ -219,6 +219,7 @@ let safe_register_pressure = function Iextcall(_, _) -> if abi = EABI then 0 else 4 | Ialloc _ -> if abi = EABI then 0 else 7 | Iconst_symbol _ when !pic_code -> 7 + | Iintop Imulh when !arch < ARMv6 -> 8 | _ -> 9 let max_register_pressure = function @@ -227,6 +228,7 @@ let max_register_pressure = function | Iconst_symbol _ when !pic_code -> [| 7; 16; 32 |] | Iintoffloat | Ifloatofint | Iload(Single, _) | Istore(Single, _, _) -> [| 9; 15; 31 |] + | Iintop Imulh when !arch < ARMv6 -> [| 8; 16; 32 |] | _ -> [| 9; 16; 32 |] (* Pure operations (without any side effect besides updating their result diff --git a/asmcomp/arm/selection.ml b/asmcomp/arm/selection.ml index 9cd6090c..4725942b 100644 --- a/asmcomp/arm/selection.ml +++ b/asmcomp/arm/selection.ml @@ -48,6 +48,8 @@ let select_shiftop = function exception Use_default let r1 = phys_reg 1 +let r6 = phys_reg 6 +let r7 = phys_reg 7 let r12 = phys_reg 8 let pseudoregs_for_operation op arg res = @@ -58,10 +60,12 @@ let pseudoregs_for_operation op arg res = Iintop Imul | Ispecific Imuladd when !arch < ARMv6 -> (arg, [| res.(0); arg.(0) |]) (* For smull rdlo,rdhi,rn,rm (pre-ARMv6) the registers rdlo, rdhi and rn - must be different. We deal with this by pretending that rn is also a - result of the smull operation. *) + must be different. Also, rdlo (whose contents we discard) is always + forced to be r12 in proc.ml, which means that neither rdhi and rn can + be r12. To keep things simple, we force both of those two to specific + hard regs: rdhi in r6 and rn in r7. *) | Iintop Imulh when !arch < ARMv6 -> - (arg, [| res.(0); arg.(0) |]) + ([| r7; arg.(1) |], [| r6 |]) (* Soft-float Iabsf and Inegf: arg.(0) and res.(0) must be the same *) | Iabsf | Inegf when !fpu = Soft -> ([|res.(0); arg.(1)|], res) diff --git a/asmrun/backtrace.c b/asmrun/backtrace.c index c72a2373..05e0d6b2 100644 --- a/asmrun/backtrace.c +++ b/asmrun/backtrace.c @@ -332,13 +332,37 @@ CAMLprim value caml_get_exception_raw_backtrace(value unit) { CAMLparam0(); CAMLlocal1(res); + const int tag = 0; - res = caml_alloc(caml_backtrace_pos, 0); - if(caml_backtrace_buffer != NULL) { + /* Beware: the allocations below may cause finalizers to be run, and another + backtrace---possibly of a different length---to be stashed (for example + if the finalizer raises then catches an exception). We choose to ignore + any such finalizer backtraces and return the original one. */ + + if (caml_backtrace_buffer == NULL || caml_backtrace_pos == 0) { + res = caml_alloc(0, tag); + } + else { + code_t saved_caml_backtrace_buffer[BACKTRACE_BUFFER_SIZE]; + int saved_caml_backtrace_pos; intnat i; - for(i = 0; i < caml_backtrace_pos; i++) - Field(res, i) = Val_Descrptr(caml_backtrace_buffer[i]); + + saved_caml_backtrace_pos = caml_backtrace_pos; + + if (saved_caml_backtrace_pos > BACKTRACE_BUFFER_SIZE) { + saved_caml_backtrace_pos = BACKTRACE_BUFFER_SIZE; + } + + memcpy(saved_caml_backtrace_buffer, caml_backtrace_buffer, + saved_caml_backtrace_pos * sizeof(code_t)); + + res = caml_alloc(saved_caml_backtrace_pos, tag); + for (i = 0; i < saved_caml_backtrace_pos; i++) { + /* [Val_Descrptr] always returns an immediate. */ + Field(res, i) = Val_Descrptr(saved_caml_backtrace_buffer[i]); + } } + CAMLreturn(res); } @@ -355,19 +379,16 @@ CAMLprim value caml_get_exception_raw_backtrace(value unit) CAMLprim value caml_get_exception_backtrace(value unit) { CAMLparam0(); - CAMLlocal4(arr, raw_slot, slot, res); + CAMLlocal3(arr, res, backtrace); + intnat i; - arr = caml_alloc(caml_backtrace_pos, 0); - if (caml_backtrace_buffer == NULL) { - Assert(caml_backtrace_pos == 0); - } else { - intnat i; - for(i = 0; i < caml_backtrace_pos; i++) { - raw_slot = Val_Descrptr(caml_backtrace_buffer[i]); - slot = caml_convert_raw_backtrace_slot(raw_slot); - caml_modify(&Field(arr, i), slot); - } + backtrace = caml_get_exception_raw_backtrace(Val_unit); + + arr = caml_alloc(Wosize_val(backtrace), 0); + for (i = 0; i < Wosize_val(backtrace); i++) { + Store_field(arr, i, caml_convert_raw_backtrace_slot(Field(backtrace, i))); } + res = caml_alloc_small(1, 0); Field(res, 0) = arr; /* Some */ CAMLreturn(res); } diff --git a/asmrun/signals_osdep.h b/asmrun/signals_osdep.h index 23165ad6..f3b4642d 100644 --- a/asmrun/signals_osdep.h +++ b/asmrun/signals_osdep.h @@ -130,6 +130,22 @@ #define CONTEXT_YOUNG_PTR (context->uc_mcontext.gregs[REG_R15]) #define CONTEXT_FAULTING_ADDRESS ((char *) info->si_addr) +/****************** AMD64, OpenBSD */ + +#elif defined(TARGET_amd64) && defined (SYS_openbsd) + + #define DECLARE_SIGNAL_HANDLER(name) \ + static void name(int sig, siginfo_t * info, struct sigcontext * context) + + #define SET_SIGACT(sigact,name) \ + sigact.sa_sigaction = (void (*)(int,siginfo_t *,void *)) (name); \ + sigact.sa_flags = SA_SIGINFO + + #define CONTEXT_PC (context->sc_rip) + #define CONTEXT_EXCEPTION_POINTER (context->sc_r14) + #define CONTEXT_YOUNG_PTR (context->sc_r15) + #define CONTEXT_FAULTING_ADDRESS ((char *) info->si_addr) + /****************** I386, Linux */ #elif defined(TARGET_i386) && defined(SYS_linux_elf) @@ -143,6 +159,20 @@ #define CONTEXT_FAULTING_ADDRESS ((char *) context.cr2) +/****************** I386, BSD_ELF */ + +#elif defined(TARGET_i386) && defined(SYS_bsd_elf) + + #define DECLARE_SIGNAL_HANDLER(name) \ + static void name(int sig, siginfo_t * info, struct sigcontext * context) + + #define SET_SIGACT(sigact,name) \ + sigact.sa_sigaction = (void (*)(int,siginfo_t *,void *)) (name); \ + sigact.sa_flags = SA_SIGINFO + + #define CONTEXT_PC (context->sc_eip) + #define CONTEXT_FAULTING_ADDRESS ((char *) info->si_addr) + /****************** I386, BSD */ #elif defined(TARGET_i386) && defined(SYS_bsd) diff --git a/boot/ocamlc b/boot/ocamlc index f6b63f10..a1aec5db 100755 Binary files a/boot/ocamlc and b/boot/ocamlc differ diff --git a/boot/ocamldep b/boot/ocamldep index d6901318..2760d2f9 100755 Binary files a/boot/ocamldep and b/boot/ocamldep differ diff --git a/boot/ocamllex b/boot/ocamllex index 02854fa1..80acc9ea 100755 Binary files a/boot/ocamllex and b/boot/ocamllex differ diff --git a/bytecomp/bytegen.ml b/bytecomp/bytegen.ml index af5f0a3f..aa98a6b3 100644 --- a/bytecomp/bytegen.ml +++ b/bytecomp/bytegen.ml @@ -441,7 +441,6 @@ let rec comp_expr env exp sz cont = let ofs = Ident.find_same id env.ce_rec in Koffsetclosure(ofs) :: cont with Not_found -> - Format.eprintf "%a@." Ident.print id; fatal_error ("Bytegen.comp_expr: var " ^ Ident.unique_name id) end | Lconst cst -> diff --git a/bytecomp/bytepackager.ml b/bytecomp/bytepackager.ml index 3348f46d..05ebac9a 100644 --- a/bytecomp/bytepackager.ml +++ b/bytecomp/bytepackager.ml @@ -222,9 +222,10 @@ let package_object_files ppf files targetfile targetname coercion = targetname Subst.identity members in build_global_target oc targetname members mapping ofs coercion; let pos_debug = pos_out oc in - if !Clflags.debug && !events <> [] then + if !Clflags.debug && !events <> [] then begin output_value oc (List.rev !events); output_value oc (StringSet.elements !debug_dirs); + end; let pos_final = pos_out oc in let imports = List.filter diff --git a/bytecomp/emitcode.ml b/bytecomp/emitcode.ml index 77df4611..e9a97765 100644 --- a/bytecomp/emitcode.ml +++ b/bytecomp/emitcode.ml @@ -143,6 +143,7 @@ let record_event ev = let path = ev.ev_loc.Location.loc_start.Lexing.pos_fname in let abspath = Location.absolute_path path in debug_dirs := StringSet.add (Filename.dirname abspath) !debug_dirs; + if Filename.is_relative path then debug_dirs := StringSet.add (Sys.getcwd ()) !debug_dirs; ev.ev_pos <- !out_position; events := ev :: !events diff --git a/bytecomp/lambda.ml b/bytecomp/lambda.ml index 4ad8e9b4..5d9fb593 100644 --- a/bytecomp/lambda.ml +++ b/bytecomp/lambda.ml @@ -537,9 +537,12 @@ let lam_of_loc kind loc = Const_base (Const_int enum); ])) | Loc_FILE -> Lconst (Const_immstring file) - | Loc_MODULE -> Lconst (Const_immstring - (String.capitalize - (Filename.chop_extension (Filename.basename file)))) + | Loc_MODULE -> + let filename = Filename.basename file in + let module_name = + try String.capitalize (Filename.chop_extension filename) + with Invalid_argument _ -> "//"^filename^"//" + in Lconst (Const_immstring module_name) | Loc_LOC -> let loc = Printf.sprintf "File %S, line %d, characters %d-%d" file lnum cnum enum in diff --git a/bytecomp/translcore.ml b/bytecomp/translcore.ml index 876abaa9..ef7d82cd 100644 --- a/bytecomp/translcore.ml +++ b/bytecomp/translcore.ml @@ -669,7 +669,7 @@ and transl_exp0 e = transl_function e.exp_loc !Clflags.native_code repr partial pl) in Lfunction(kind, params, body) - | Texp_apply({exp_desc = Texp_ident(path, _, {val_kind = Val_prim p})} as fn, + | Texp_apply({exp_desc = Texp_ident(path, _, {val_kind = Val_prim p})}, oargs) when List.length oargs >= p.prim_arity && List.for_all (fun (_, arg,_) -> arg <> None) oargs -> @@ -695,12 +695,6 @@ and transl_exp0 e = wrap (Lsend(Cached, meth, obj, [cache; pos], e.exp_loc)) | _ -> assert false else begin - if p.prim_name = "%sequand" && Path.last path = "&" then - Location.prerr_warning fn.exp_loc - (Warnings.Deprecated "operator (&); you should use (&&) instead"); - if p.prim_name = "%sequor" && Path.last path = "or" then - Location.prerr_warning fn.exp_loc - (Warnings.Deprecated "operator (or); you should use (||) instead"); let prim = transl_prim e.exp_loc p args in match (prim, args) with (Praise k, [arg1]) -> diff --git a/bytecomp/translmod.ml b/bytecomp/translmod.ml index dc7d2d7a..a2944f3d 100644 --- a/bytecomp/translmod.ml +++ b/bytecomp/translmod.ml @@ -83,21 +83,12 @@ let rec apply_coercion strict restr arg = arg | Tcoerce_structure(pos_cc_list, id_pos_list) -> name_lambda strict arg (fun id -> + let get_field pos = Lprim(Pfield pos,[Lvar id]) in let lam = Lprim(Pmakeblock(0, Immutable), - List.map (apply_coercion_field id) pos_cc_list) in - let fv = free_variables lam in - let (lam,s) = - List.fold_left (fun (lam,s) (id',pos,c) -> - if IdentSet.mem id' fv then - let id'' = Ident.create (Ident.name id') in - (Llet(Alias,id'', - apply_coercion Alias c (Lprim(Pfield pos,[Lvar id])),lam), - Ident.add id' (Lvar id'') s) - else (lam,s)) - (lam, Ident.empty) id_pos_list + List.map (apply_coercion_field get_field) pos_cc_list) in - if s == Ident.empty then lam else subst_lambda s lam) + wrap_id_pos_list id_pos_list get_field lam) | Tcoerce_functor(cc_arg, cc_res) -> let param = Ident.create "funarg" in name_lambda strict arg (fun id -> @@ -111,8 +102,26 @@ let rec apply_coercion strict restr arg = name_lambda strict arg (fun id -> apply_coercion Alias cc (transl_normal_path path)) -and apply_coercion_field id (pos, cc) = - apply_coercion Alias cc (Lprim(Pfield pos, [Lvar id])) +and apply_coercion_field get_field (pos, cc) = + apply_coercion Alias cc (get_field pos) + +and wrap_id_pos_list id_pos_list get_field lam = + let fv = free_variables lam in + (*Format.eprintf "%a@." Printlambda.lambda lam; + IdentSet.iter (fun id -> Format.eprintf "%a " Ident.print id) fv; + Format.eprintf "@.";*) + let (lam,s) = + List.fold_left (fun (lam,s) (id',pos,c) -> + if IdentSet.mem id' fv then + let id'' = Ident.create (Ident.name id') in + (Llet(Alias,id'', + apply_coercion Alias c (get_field pos),lam), + Ident.add id' (Lvar id'') s) + else (lam,s)) + (lam, Ident.empty) id_pos_list + in + if s == Ident.empty then lam else subst_lambda s lam + (* Compose two coercions apply_coercion c1 (apply_coercion c2 e) behaves like @@ -154,7 +163,7 @@ let compose_coercions c1 c2 = let c3 = compose_coercions c1 c2 in let open Includemod in Format.eprintf "@[<2>compose_coercions@ (%a)@ (%a) =@ %a@]@." - print_coercion c1 print_coercion c2 print_coercion c2; + print_coercion c1 print_coercion c2 print_coercion c3; c3 *) @@ -322,7 +331,7 @@ let rec transl_module cc rootpath mexp = | _ -> match mexp.mod_desc with Tmod_ident (path,_) -> - apply_coercion StrictOpt cc + apply_coercion Strict cc (transl_path ~loc:mexp.mod_loc mexp.mod_env path) | Tmod_structure str -> transl_struct [] cc rootpath str @@ -362,18 +371,26 @@ and transl_structure fields cc rootpath = function Lprim(Pmakeblock(0, Immutable), List.map (fun id -> Lvar id) (List.rev fields)) | Tcoerce_structure(pos_cc_list, id_pos_list) -> - (* ignore id_pos_list as the ids are already bound *) + (* Do not ignore id_pos_list ! *) + (*Format.eprintf "%a@.@[" Includemod.print_coercion cc; + List.iter (fun l -> Format.eprintf "%a@ " Ident.print l) + fields; + Format.eprintf "@]@.";*) let v = Array.of_list (List.rev fields) in - (*List.fold_left - (fun lam (id, pos) -> Llet(Alias, id, Lvar v.(pos), lam))*) + let get_field pos = Lvar v.(pos) + and ids = List.fold_right IdentSet.add fields IdentSet.empty in + let lam = (Lprim(Pmakeblock(0, Immutable), List.map (fun (pos, cc) -> match cc with Tcoerce_primitive p -> transl_primitive Location.none p - | _ -> apply_coercion Strict cc (Lvar v.(pos))) + | _ -> apply_coercion Strict cc (get_field pos)) pos_cc_list)) - (*id_pos_list*) + and id_pos_list = + List.filter (fun (id,_,_) -> not (IdentSet.mem id ids)) id_pos_list + in + wrap_id_pos_list id_pos_list get_field lam | _ -> fatal_error "Translmod.transl_structure" end diff --git a/byterun/gc_ctrl.c b/byterun/gc_ctrl.c index 7e61f0c1..1ab099da 100644 --- a/byterun/gc_ctrl.c +++ b/byterun/gc_ctrl.c @@ -321,7 +321,7 @@ CAMLprim value caml_gc_get(value v) res = caml_alloc_tuple (7); Store_field (res, 0, Val_long (Wsize_bsize (caml_minor_heap_size))); /* s */ - Store_field (res, 1,Val_long(Wsize_bsize(caml_major_heap_increment)));/* i */ + Store_field (res, 1, Val_long (caml_major_heap_increment)); /* i */ Store_field (res, 2, Val_long (caml_percent_free)); /* o */ Store_field (res, 3, Val_long (caml_verb_gc)); /* v */ Store_field (res, 4, Val_long (caml_percent_max)); /* O */ diff --git a/config/Makefile.mingw b/config/Makefile.mingw index d9e7607f..c2049803 100644 --- a/config/Makefile.mingw +++ b/config/Makefile.mingw @@ -110,7 +110,7 @@ CPP=$(BYTECC) -E ### Flexlink FLEXLINK=flexlink -chain mingw -stack 16777216 -link -static-libgcc -FLEXDIR=$(shell $(FLEXLINK) -where) +FLEXDIR:=$(shell $(FLEXLINK) -where) IFLEXDIR=-I"$(FLEXDIR)" MKDLL=$(FLEXLINK) MKEXE=$(FLEXLINK) -exe diff --git a/config/Makefile.mingw64 b/config/Makefile.mingw64 index 44784b68..0a3bdfbd 100644 --- a/config/Makefile.mingw64 +++ b/config/Makefile.mingw64 @@ -110,7 +110,7 @@ CPP=$(BYTECC) -E ### Flexlink FLEXLINK=flexlink -chain mingw64 -stack 33554432 -FLEXDIR=$(shell $(FLEXLINK) -where) +FLEXDIR:=$(shell $(FLEXLINK) -where) IFLEXDIR=-I"$(FLEXDIR)" MKDLL=$(FLEXLINK) MKEXE=$(FLEXLINK) -exe diff --git a/config/Makefile.msvc b/config/Makefile.msvc index 3ab6c6eb..93cf94b6 100644 --- a/config/Makefile.msvc +++ b/config/Makefile.msvc @@ -63,7 +63,7 @@ SUPPORTS_SHARED_LIBRARIES=true SHAREDCCCOMPOPTS= NATIVECCPROFOPTS= NATIVECCRPATH= -ASM=ml /nologo /coff /Cp /c /Fo +ASM=ml -nologo -coff -Cp -c -Fo ASPP= ASPPPROFFLAGS= PROFILING=noprof @@ -81,35 +81,35 @@ GRAPHLIB=win32graph ########## Configuration for the bytecode compiler ### Which C compiler to use for the bytecode interpreter. -BYTECC=cl /nologo -D_CRT_SECURE_NO_DEPRECATE +BYTECC=cl -nologo -D_CRT_SECURE_NO_DEPRECATE ### Additional compile-time options for $(BYTECC). (For static linking.) -BYTECCCOMPOPTS=/Ox /MD +BYTECCCOMPOPTS=-Ox -MD ### Additional link-time options for $(BYTECC). (For static linking.) BYTECCLINKOPTS= ### Additional compile-time options for $(BYTECC). (For building a DLL.) -DLLCCCOMPOPTS=/Ox /MD +DLLCCCOMPOPTS=-Ox -MD ### Libraries needed BYTECCLIBS=advapi32.lib ws2_32.lib NATIVECCLIBS=advapi32.lib ws2_32.lib ### How to invoke the C preprocessor -CPP=cl /nologo /EP +CPP=cl -nologo -EP ### Flexlink FLEXLINK=flexlink -merge-manifest -stack 16777216 -FLEXDIR=$(shell $(FLEXLINK) -where) +FLEXDIR:=$(shell $(FLEXLINK) -where) IFLEXDIR=-I"$(FLEXDIR)" MKDLL=$(FLEXLINK) MKEXE=$(FLEXLINK) -exe MKMAINDLL=$(FLEXLINK) -maindll ### How to build a static library -MKLIB=link /lib /nologo /out:$(1) $(2) -#ml let mklib out files opts = Printf.sprintf "link /lib /nologo /out:%s %s %s" out opts files;; +MKLIB=link -lib -nologo -out:$(1) $(2) +#ml let mklib out files opts = Printf.sprintf "link -lib -nologo -out:%s %s %s" out opts files;; MKSHAREDLIBRPATH= ### Canonicalize the name of a system library @@ -135,16 +135,16 @@ MODEL=default SYSTEM=win32 ### Which C compiler to use for the native-code compiler. -NATIVECC=cl /nologo -D_CRT_SECURE_NO_DEPRECATE +NATIVECC=cl -nologo -D_CRT_SECURE_NO_DEPRECATE ### Additional compile-time options for $(NATIVECC). -NATIVECCCOMPOPTS=/Ox /MD +NATIVECCCOMPOPTS=-Ox -MD ### Additional link-time options for $(NATIVECC) NATIVECCLINKOPTS= ### Build partially-linked object file -PACKLD=link /lib /nologo /out:# there must be no space after this '/out:' +PACKLD=link -lib -nologo -out:# there must be no space after this '-out:' ### Clear this to disable compiling ocamldebug WITH_DEBUGGER=ocamldebugger diff --git a/config/Makefile.msvc64 b/config/Makefile.msvc64 index 8437cf4b..1b2e1888 100644 --- a/config/Makefile.msvc64 +++ b/config/Makefile.msvc64 @@ -63,7 +63,7 @@ SUPPORTS_SHARED_LIBRARIES=true SHAREDCCCOMPOPTS= NATIVECCPROFOPTS= NATIVECCRPATH= -ASM=ml64 /nologo /Cp /c /Fo +ASM=ml64 -nologo -Cp -c -Fo ASPP= ASPPPROFFLAGS= PROFILING=noprof @@ -80,19 +80,19 @@ GRAPHLIB=win32graph ########## Configuration for the bytecode compiler ### Which C compiler to use for the bytecode interpreter. -BYTECC=cl /nologo -D_CRT_SECURE_NO_DEPRECATE +BYTECC=cl -nologo -D_CRT_SECURE_NO_DEPRECATE ### Additional compile-time options for $(BYTECC). (For static linking.) -BYTECCCOMPOPTS=/Ox /MD +BYTECCCOMPOPTS=-Ox -MD ### Additional compile-time options for $(BYTECC). (For debug version.) -BYTECCDBGCOMPOPTS=-DDEBUG /Zi /W3 /Wp64 +BYTECCDBGCOMPOPTS=-DDEBUG -Zi -W3 -Wp64 ### Additional link-time options for $(BYTECC). (For static linking.) BYTECCLINKOPTS= ### Additional compile-time options for $(BYTECC). (For building a DLL.) -DLLCCCOMPOPTS=/Ox /MD +DLLCCCOMPOPTS=-Ox -MD ### Libraries needed #EXTRALIBS=bufferoverflowu.lib # for the old PSDK compiler only @@ -101,19 +101,19 @@ BYTECCLIBS=advapi32.lib ws2_32.lib $(EXTRALIBS) NATIVECCLIBS=advapi32.lib ws2_32.lib $(EXTRALIBS) ### How to invoke the C preprocessor -CPP=cl /nologo /EP +CPP=cl -nologo -EP ### Flexlink FLEXLINK=flexlink -x64 -merge-manifest -stack 33554432 -FLEXDIR=$(shell $(FLEXLINK) -where) +FLEXDIR:=$(shell $(FLEXLINK) -where) IFLEXDIR=-I"$(FLEXDIR)" MKDLL=$(FLEXLINK) MKEXE=$(FLEXLINK) -exe MKMAINDLL=$(FLEXLINK) -maindll ### How to build a static library -MKLIB=link /lib /nologo /machine:AMD64 /out:$(1) $(2) -#ml let mklib out files opts = Printf.sprintf "link /lib /nologo /machine:AMD64 /out:%s %s %s" out opts files;; +MKLIB=link -lib -nologo -machine:AMD64 /out:$(1) $(2) +#ml let mklib out files opts = Printf.sprintf "link -lib -nologo -machine:AMD64 -out:%s %s %s" out opts files;; MKSHAREDLIBRPATH= ### Canonicalize the name of a system library @@ -139,16 +139,16 @@ MODEL=default SYSTEM=win64 ### Which C compiler to use for the native-code compiler. -NATIVECC=cl /nologo +NATIVECC=cl -nologo ### Additional compile-time options for $(NATIVECC). -NATIVECCCOMPOPTS=/Ox /MD +NATIVECCCOMPOPTS=-Ox -MD ### Additional link-time options for $(NATIVECC) NATIVECCLINKOPTS= ### Build partially-linked object file -PACKLD=link /lib /nologo /machine:AMD64 /out:# must have no space after '/out:' +PACKLD=link -lib -nologo -machine:AMD64 -out:# must have no space after '-out:' ### Clear this to disable compiling ocamldebug WITH_DEBUGGER=ocamldebugger diff --git a/config/s-nt.h b/config/s-nt.h index 6df440b8..e8aa8785 100644 --- a/config/s-nt.h +++ b/config/s-nt.h @@ -27,3 +27,4 @@ #define HAS_LOCALE #define HAS_BROKEN_PRINTF #define HAS_IPV6 +#define HAS_NICE diff --git a/config/s-templ.h b/config/s-templ.h index d0748ae2..383b4015 100644 --- a/config/s-templ.h +++ b/config/s-templ.h @@ -212,3 +212,7 @@ The value of this symbol is the number of arguments of gethostbyaddr_r(): either 7 or 8 depending on prototype. (7 is the Solaris version, 8 is the Linux version). */ + +#define HAS_NICE + +/* Define HAS_NICE if you have nice(). */ diff --git a/configure b/configure index dbc61780..3edb9fd2 100755 --- a/configure +++ b/configure @@ -333,6 +333,10 @@ case "$bytecc,$target" in echo "#ifndef __PIC__" >> m.h echo "# define ARCH_CODE32" >> m.h echo "#endif" >> m.h;; + *,*-*-haiku*) + bytecccompopts="-fno-defer-pop $gcc_warnings" + # No -lm library + mathlib="";; *,*-*-beos*) bytecccompopts="-fno-defer-pop $gcc_warnings" # No -lm library @@ -655,7 +659,7 @@ if test $with_sharedlibs = "yes"; then mksharedlib="$flexlink" mkmaindll="$flexlink -maindll" shared_libraries_supported=true;; - *-*-linux-gnu|*-*-linux|*-*-freebsd[3-9]*|*-*-freebsd[1-9][0-9]*|*-*-openbsd*|*-*-netbsd*|*-*-gnu*) + *-*-linux-gnu|*-*-linux|*-*-freebsd[3-9]*|*-*-freebsd[1-9][0-9]*|*-*-openbsd*|*-*-netbsd*|*-*-gnu*|*-*-haiku*) sharedcccompopts="-fPIC" mksharedlib="$bytecc -shared" bytecclinkopts="$bytecclinkopts -Wl,-E" @@ -767,6 +771,7 @@ if test $with_sharedlibs = "yes"; then i[3456]86-*-netbsd*) natdynlink=true;; x86_64-*-netbsd*) natdynlink=true;; i386-*-gnu0.3) natdynlink=true;; + i[3456]86-*-haiku*) natdynlink=true;; arm*-*-linux*) natdynlink=true;; arm*-*-freebsd*) natdynlink=true;; aarch64-*-linux*) natdynlink=true;; @@ -799,6 +804,7 @@ case "$target" in else arch=i386; system=solaris fi;; + i[3456]86-*-haiku*) arch=i386; system=beos;; i[3456]86-*-beos*) arch=i386; system=beos;; i[3456]86-*-cygwin*) arch=i386; system=cygwin;; i[3456]86-*-darwin*) if $arch64; then @@ -875,7 +881,7 @@ esac asppprofflags='-DPROFILING' case "$arch,$system" in - amd64,macosx) if ./searchpath clang; then + amd64,macosx) if sh ./searchpath clang; then as='clang -arch x86_64 -c' aspp='clang -arch x86_64 -c' else @@ -1046,11 +1052,17 @@ if sh ./hasgot socket socketpair bind listen accept connect; then inf "You have BSD sockets." echo "#define HAS_SOCKETS" >> s.h has_sockets=yes -elif sh ./hasgot -lnsl -lsocket socket socketpair bind listen accept connect; then +elif sh ./hasgot -lnsl -lsocket socket socketpair bind listen accept connect +then inf "You have BSD sockets (with libraries '-lnsl -lsocket')" cclibs="$cclibs -lnsl -lsocket" echo "#define HAS_SOCKETS" >> s.h has_sockets=yes +elif sh ./hasgot -lnetwork socket socketpair bind listen accept connect; then + echo "You have BSD sockets (with library '-lnetwork')" + cclibs="$cclibs -lnetwork" + echo "#define HAS_SOCKETS" >> s.h + has_sockets=yes else case "$target" in *-*-mingw*) @@ -1309,6 +1321,11 @@ if sh ./hasgot mkstemp; then echo "#define HAS_MKSTEMP" >> s.h fi +if sh ./hasgot nice; then + inf "nice() found" + echo "#define HAS_NICE" >> s.h +fi + # Determine if the debugger is supported if test -n "$with_debugger"; then @@ -1324,7 +1341,8 @@ fi # Determine if system stack overflows can be detected case "$arch,$system" in - i386,linux_elf|amd64,linux|power,rhapsody|amd64,macosx|i386,macosx) + i386,linux_elf|amd64,linux|power,rhapsody|amd64,macosx|i386,macosx \ + |amd64,openbsd|i386,bsd_elf) inf "System stack overflow can be detected." echo "#define HAS_STACK_OVERFLOW_DETECTION" >> s.h;; *) @@ -1360,10 +1378,12 @@ if test "$pthread_wanted" = "yes"; then pthread_caml_link="-cclib -pthread";; *-*-openbsd*) pthread_link="-pthread" pthread_caml_link="-cclib -pthread";; + *-*-haiku*) pthread_link="" + pthread_caml_link="";; *) pthread_link="-lpthread" pthread_caml_link="-cclib -lpthread";; esac - if ./hasgot -i pthread.h $pthread_link pthread_self; then + if sh ./hasgot -i pthread.h $pthread_link pthread_self; then inf "POSIX threads library supported." systhread_support=true otherlibraries="$otherlibraries systhreads" @@ -1390,7 +1410,8 @@ if test "$pthread_wanted" = "yes"; then else pthread_link="" fi -echo "PTHREAD_LINK=$pthread_caml_link" >> Makefile +echo "PTHREAD_LINK=$pthread_link" >> Makefile +echo "PTHREAD_CAML_LINK=$pthread_caml_link" >> Makefile # Determine if the bytecode thread library is supported @@ -1553,7 +1574,7 @@ if test "x11_include" != "not found"; then if test "$x11_include" = "-I/usr/include"; then x11_include="" fi - if ./hasgot $x11_include $x11_link -i X11/Xlib.h XrmInitialize; then + if sh ./hasgot $x11_include $x11_link -i X11/Xlib.h XrmInitialize; then inf "X11 works" else wrn "Cannot compile X11 program." @@ -1581,8 +1602,8 @@ echo "X11_LINK=$x11_link" >> Makefile # Look for BFD library -if ./hasgot -i bfd.h && \ - ./hasgot -lbfd -ldl -liberty -lz bfd_openr; then +if sh ./hasgot -DPACKAGE=ocaml -i bfd.h && \ + sh ./hasgot -DPACKAGE=ocaml -lbfd -ldl -liberty -lz bfd_openr; then inf "BFD library found." echo "#define HAS_LIBBFD" >> s.h echo "LIBBFD_LINK=-lbfd -ldl -liberty -lz" >> Makefile diff --git a/debugger/source.ml b/debugger/source.ml index af69fbc7..aa9ec708 100644 --- a/debugger/source.ml +++ b/debugger/source.ml @@ -50,10 +50,10 @@ let source_of_module pos mdle = try find_in_path_uncap path (innermost_module ^ ext) with Not_found -> loop exts in loop source_extensions - else if Filename.is_implicit fname then - find_in_path path fname - else - fname + else if Filename.is_relative fname then + find_in_path_rel path fname + else if Sys.file_exists fname then fname + else raise Not_found (*** Buffer cache ***) diff --git a/driver/main_args.ml b/driver/main_args.ml index 4f9668c7..7636abe0 100644 --- a/driver/main_args.ml +++ b/driver/main_args.ml @@ -501,7 +501,7 @@ module type Common_options = sig val anonymous : string -> unit end;; -module type Compiler_options = sig +module type Compiler_options = sig val _a : unit -> unit val _annot : unit -> unit val _binannot : unit -> unit @@ -608,6 +608,22 @@ module type Opttop_options = sig val _stdin : unit -> unit end;; +module type Ocamldoc_options = sig + include Common_options + val _impl : string -> unit + val _intf : string -> unit + val _intf_suffix : string -> unit + val _pp : string -> unit + val _principal : unit -> unit + val _rectypes : unit -> unit + val _safe_string : unit -> unit + val _short_paths : unit -> unit + val _thread : unit -> unit + val _v : unit -> unit + val _verbose : unit -> unit + val _vmthread : unit -> unit +end;; + module type Arg_list = sig val list : (string * Arg.spec * string) list end;; @@ -874,3 +890,40 @@ module Make_opttop_options (F : Opttop_options) = struct mk_dstartup F._dstartup; ] end;; + +module Make_ocamldoc_options (F : Ocamldoc_options) = +struct + let list = [ + mk_absname F._absname; + mk_I F._I; + mk_impl F._impl; + mk_intf F._intf; + mk_intf_suffix F._intf_suffix; + mk_intf_suffix_2 F._intf_suffix; + mk_labels F._labels; + mk_modern F._labels; + mk_no_alias_deps F._no_alias_deps; + mk_no_app_funct F._no_app_funct; + mk_noassert F._noassert; + mk_nolabels F._nolabels; + mk_nostdlib F._nostdlib; + mk_open F._open; + mk_pp F._pp; + mk_ppx F._ppx; + mk_principal F._principal; + mk_rectypes F._rectypes; + mk_safe_string F._safe_string; + mk_short_paths F._short_paths; + mk_strict_sequence F._strict_sequence; + mk_strict_formats F._strict_formats; + mk_thread F._thread; + mk_unsafe_string F._unsafe_string; + mk_v F._v; + mk_verbose F._verbose; + mk_version F._version; + mk_vmthread F._vmthread; + mk_vnum F._vnum; + mk_w F._w; + mk__ F.anonymous; + ] +end;; diff --git a/driver/main_args.mli b/driver/main_args.mli index 95b7c69e..18ade80b 100644 --- a/driver/main_args.mli +++ b/driver/main_args.mli @@ -10,6 +10,9 @@ (* *) (***********************************************************************) +(* ATTENTION ! When you add or modify a parsing or typing option, do not forget + to update ocamldoc options too, in odoc_args.ml. *) + module type Common_options = sig val _absname : unit -> unit val _I : string -> unit @@ -152,6 +155,22 @@ module type Opttop_options = sig val _stdin : unit -> unit end;; +module type Ocamldoc_options = sig + include Common_options + val _impl : string -> unit + val _intf : string -> unit + val _intf_suffix : string -> unit + val _pp : string -> unit + val _principal : unit -> unit + val _rectypes : unit -> unit + val _safe_string : unit -> unit + val _short_paths : unit -> unit + val _thread : unit -> unit + val _v : unit -> unit + val _verbose : unit -> unit + val _vmthread : unit -> unit +end + module type Arg_list = sig val list : (string * Arg.spec * string) list end;; @@ -160,3 +179,4 @@ module Make_bytecomp_options (F : Bytecomp_options) : Arg_list;; module Make_bytetop_options (F : Bytetop_options) : Arg_list;; module Make_optcomp_options (F : Optcomp_options) : Arg_list;; module Make_opttop_options (F : Opttop_options) : Arg_list;; +module Make_ocamldoc_options (F : Ocamldoc_options) : Arg_list;; diff --git a/driver/pparse.ml b/driver/pparse.ml index 08b9bc73..4b2553f2 100644 --- a/driver/pparse.ml +++ b/driver/pparse.ml @@ -39,6 +39,10 @@ let remove_preprocessed inputfile = None -> () | Some _ -> Misc.remove_file inputfile + +(* Note: some of the functions here should go to Ast_mapper instead, + which would encapsulate the "binary AST" protocol. *) + let write_ast magic ast = let fn = Filename.temp_file "camlppx" "" in let oc = open_out_bin fn in @@ -87,41 +91,34 @@ let read_ast magic fn = Misc.remove_file fn; raise exn -let apply_rewriters ~tool_name magic ast = - let ctx = Ast_mapper.ppx_context ~tool_name () in +let rewrite magic ast ppxs = + read_ast magic + (List.fold_left (apply_rewriter magic) (write_ast magic ast) + (List.rev ppxs)) + +let apply_rewriters_str ?(restore = true) ~tool_name ast = match !Clflags.all_ppx with | [] -> ast | ppxs -> - let ast = - if magic = Config.ast_impl_magic_number - then Obj.magic (Ast_helper.Str.attribute ctx :: (Obj.magic ast)) - else Obj.magic (Ast_helper.Sig.attribute ctx :: (Obj.magic ast)) - in - let fn = - List.fold_left (apply_rewriter magic) (write_ast magic ast) - (List.rev ppxs) - in - let ast = read_ast magic fn in - let open Parsetree in - if magic = Config.ast_impl_magic_number then - let ast = - match Obj.magic ast with - | {pstr_desc = Pstr_attribute({Location.txt = "ocaml.ppx.context"}, _)} - :: items -> - items - | items -> items - in - Obj.magic ast - else - let ast = - match Obj.magic ast with - | {psig_desc = Psig_attribute({Location.txt = "ocaml.ppx.context"}, _)} - :: items -> - items - | items -> items - in - Obj.magic ast + let ast = Ast_mapper.add_ppx_context_str ~tool_name ast in + let ast = rewrite Config.ast_impl_magic_number ast ppxs in + Ast_mapper.drop_ppx_context_str ~restore ast +let apply_rewriters_sig ?(restore = true) ~tool_name ast = + match !Clflags.all_ppx with + | [] -> ast + | ppxs -> + let ast = Ast_mapper.add_ppx_context_sig ~tool_name ast in + let ast = rewrite Config.ast_intf_magic_number ast ppxs in + Ast_mapper.drop_ppx_context_sig ~restore ast + +let apply_rewriters ?restore ~tool_name magic ast = + if magic = Config.ast_impl_magic_number then + Obj.magic (apply_rewriters_str ?restore ~tool_name (Obj.magic ast)) + else if magic = Config.ast_intf_magic_number then + Obj.magic (apply_rewriters_sig ?restore ~tool_name (Obj.magic ast)) + else + assert false (* Parse a file or get a dumped syntax tree from it *) @@ -160,7 +157,7 @@ let file ppf ~tool_name inputfile parse_fun ast_magic = with x -> close_in ic; raise x in close_in ic; - apply_rewriters ~tool_name ast_magic ast + apply_rewriters ~restore:false ~tool_name ast_magic ast let report_error ppf = function | CannotRun cmd -> diff --git a/driver/pparse.mli b/driver/pparse.mli index d45adf91..bcff4e78 100644 --- a/driver/pparse.mli +++ b/driver/pparse.mli @@ -21,7 +21,14 @@ exception Error of error val preprocess : string -> string val remove_preprocessed : string -> unit val file : formatter -> tool_name:string -> string -> (Lexing.lexbuf -> 'a) -> string -> 'a -val apply_rewriters : tool_name:string -> string -> 'a -> 'a +val apply_rewriters: ?restore:bool -> tool_name:string -> string -> 'a -> 'a + (** If [restore = true] (the default), cookies set by external rewriters will be + kept for later calls. *) + +val apply_rewriters_str: ?restore:bool -> tool_name:string -> Parsetree.structure -> Parsetree.structure +val apply_rewriters_sig: ?restore:bool -> tool_name:string -> Parsetree.signature -> Parsetree.signature + + val report_error : formatter -> error -> unit diff --git a/emacs/caml-types.el b/emacs/caml-types.el index 47060a2c..4bc22665 100644 --- a/emacs/caml-types.el +++ b/emacs/caml-types.el @@ -113,9 +113,9 @@ type call ident" (make-variable-buffer-local 'caml-types-annotation-date) (defvar caml-types-buffer-name "*caml-types*" - "Name of buffer for diplaying caml types") + "Name of buffer for displaying caml types") (defvar caml-types-buffer nil - "buffer for diplaying caml types") + "buffer for displaying caml types") (defun caml-types-show-type (arg) "Show the type of expression or pattern at point. diff --git a/man/ocaml.m b/man/ocaml.m index 6764d52c..79f81df0 100644 --- a/man/ocaml.m +++ b/man/ocaml.m @@ -142,8 +142,9 @@ the statements open! module1;; ... open! moduleN;; were input. .BI \-ppx \ command After parsing, pipe the abstract syntax tree through the preprocessor .IR command . -The format of the input and output of the preprocessor -are not yet documented. +The module +.BR Ast_mapper (3) +implements the external interface of a preprocessor. .TP .B \-principal Check information path during type-checking, to make sure that all diff --git a/man/ocamlc.m b/man/ocamlc.m index 8661a76a..090f1c68 100644 --- a/man/ocamlc.m +++ b/man/ocamlc.m @@ -502,8 +502,9 @@ implementation (.ml) file. .BI \-ppx \ command After parsing, pipe the abstract syntax tree through the preprocessor .IR command . -The format of the input and output of the preprocessor -are not yet documented. +The module +.BR Ast_mapper (3) +implements the external interface of a preprocessor. .TP .B \-principal Check information path during type-checking, to make sure that all diff --git a/man/ocamlopt.m b/man/ocamlopt.m index b1b173af..fb20ca99 100644 --- a/man/ocamlopt.m +++ b/man/ocamlopt.m @@ -457,8 +457,9 @@ errors, the intermediate file is deleted afterwards. .BI \-ppx \ command After parsing, pipe the abstract syntax tree through the preprocessor .IR command . -The format of the input and output of the preprocessor -are not yet documented. +The module +.BR Ast_mapper (3) +implements the external interface of a preprocessor. .TP .B \-principal Check information path during type-checking, to make sure that all diff --git a/ocamlbuild/ocaml_specific.ml b/ocamlbuild/ocaml_specific.ml index 134a1533..79517a86 100644 --- a/ocamlbuild/ocaml_specific.ml +++ b/ocamlbuild/ocaml_specific.ml @@ -612,6 +612,8 @@ let () = (fun param -> S [A "-w"; A param]); pflag ["ocaml";"compile";] "warn_error" (fun param -> S [A "-warn-error"; A param]); + pflag ["ocaml"; "ocamldep"] "open" + (fun param -> S [A "-open"; A param]); pflag ["ocaml"; "compile"] "open" (fun param -> S [A "-open"; A param]); () @@ -668,7 +670,9 @@ flag ["ocaml"; "link"; "native"; "output_obj"] (A"-output-obj");; flag ["ocaml"; "link"; "byte"; "output_obj"] (A"-output-obj");; flag ["ocaml"; "dtypes"; "compile"] (A "-dtypes");; flag ["ocaml"; "annot"; "compile"] (A "-annot");; +flag ["ocaml"; "annot"; "pack"] (A "-annot");; flag ["ocaml"; "bin_annot"; "compile"] (A "-bin-annot");; +flag ["ocaml"; "bin_annot"; "pack"] (A "-bin-annot");; flag ["ocaml"; "safe_string"; "compile"] (A "-safe-string");; flag ["ocaml"; "safe_string"; "infer_interface"] (A "-safe-string");; flag ["ocaml"; "unsafe_string"; "compile"] (A "-unsafe-string");; diff --git a/ocamlbuild/options.ml b/ocamlbuild/options.ml index 5ee51220..5193b9b9 100644 --- a/ocamlbuild/options.ml +++ b/ocamlbuild/options.ml @@ -238,8 +238,7 @@ let spec = ref ( "-ocamlyacc", set_cmd ocamlyacc, " Set the ocamlyacc tool"; "-menhir", set_cmd ocamlyacc, " Set the menhir tool (use it after -use-menhir)"; "-ocamllex", set_cmd ocamllex, " Set the ocamllex tool"; - (* Not set since we perhaps want to replace ocamlmklib *) - (* "-ocamlmklib", set_cmd ocamlmklib, " Set the ocamlmklib tool"; *) + "-ocamlmklib", set_cmd ocamlmklib, " Set the ocamlmklib tool"; "-ocamlmktop", set_cmd ocamlmktop, " Set the ocamlmktop tool"; "-ocamlrun", set_cmd ocamlrun, " Set the ocamlrun tool"; @@ -316,6 +315,7 @@ let init () = "ocamlopt", ocamlopt; "ocamldep", ocamldep; "ocamldoc", ocamldoc; + "ocamlmklib", ocamlmklib; "ocamlmktop", ocamlmktop; ] end; diff --git a/ocamlbuild/testsuite/internal.ml b/ocamlbuild/testsuite/internal.ml index fc7ff98d..d0071543 100644 --- a/ocamlbuild/testsuite/internal.ml +++ b/ocamlbuild/testsuite/internal.ml @@ -303,4 +303,15 @@ let () = test "OpenTag" ~matching:[M.f "test.byte"] ~targets:("test.byte",[]) ();; +let () = test "OpenDependencies" + ~description:"Test dependency computation for the new -open feature (PR#6584)" + ~options:[`no_ocamlfind] + ~tree:[ + T.f "a.ml" ~content:"let x = 1"; + T.f "b.ml" ~content:"print_int x; print_newline ()"; + T.f "_tags" ~content: ": open(A)"; + ] + ~matching:[M.f "b.byte"] + ~targets:("b.byte",[]) ();; + run ~root:"_test_internal";; diff --git a/ocamldoc/.depend b/ocamldoc/.depend index 0f692a22..b98bb57f 100644 --- a/ocamldoc/.depend +++ b/ocamldoc/.depend @@ -22,12 +22,18 @@ odoc_analyse.cmx : ../utils/warnings.cmx ../typing/types.cmx \ odoc_comments.cmx odoc_class.cmx odoc_ast.cmx ../utils/misc.cmx \ ../parsing/location.cmx ../typing/env.cmx ../utils/config.cmx \ ../utils/clflags.cmx odoc_analyse.cmi -odoc_args.cmo : odoc_types.cmi odoc_texi.cmo odoc_messages.cmo odoc_man.cmo \ - odoc_latex.cmo odoc_html.cmo odoc_global.cmi odoc_gen.cmi odoc_dot.cmo \ - odoc_config.cmi ../utils/misc.cmi ../utils/config.cmi odoc_args.cmi -odoc_args.cmx : odoc_types.cmx odoc_texi.cmx odoc_messages.cmx odoc_man.cmx \ - odoc_latex.cmx odoc_html.cmx odoc_global.cmx odoc_gen.cmx odoc_dot.cmx \ - odoc_config.cmx ../utils/misc.cmx ../utils/config.cmx odoc_args.cmi +odoc_args.cmo : ../utils/warnings.cmi odoc_types.cmi odoc_texi.cmo \ + odoc_messages.cmo odoc_man.cmo odoc_latex.cmo odoc_html.cmo \ + odoc_global.cmi odoc_gen.cmi odoc_dot.cmo odoc_config.cmi \ + ../utils/misc.cmi ../driver/main_args.cmi ../parsing/location.cmi \ + ../utils/config.cmi ../driver/compenv.cmi ../utils/clflags.cmi \ + odoc_args.cmi +odoc_args.cmx : ../utils/warnings.cmx odoc_types.cmx odoc_texi.cmx \ + odoc_messages.cmx odoc_man.cmx odoc_latex.cmx odoc_html.cmx \ + odoc_global.cmx odoc_gen.cmx odoc_dot.cmx odoc_config.cmx \ + ../utils/misc.cmx ../driver/main_args.cmx ../parsing/location.cmx \ + ../utils/config.cmx ../driver/compenv.cmx ../utils/clflags.cmx \ + odoc_args.cmi odoc_ast.cmo : ../typing/types.cmi ../typing/typedtree.cmi \ ../typing/predef.cmi ../typing/path.cmi ../parsing/parsetree.cmi \ odoc_value.cmo odoc_types.cmi odoc_type.cmo odoc_sig.cmi \ diff --git a/ocamldoc/Makefile b/ocamldoc/Makefile index 0e8b288b..7a487c6c 100644 --- a/ocamldoc/Makefile +++ b/ocamldoc/Makefile @@ -148,6 +148,7 @@ OCAMLCMXFILES=$(OCAMLCMOFILES:.cmo=.cmx) STDLIB_MLIS=../stdlib/*.mli \ + ../parsing/*.mli \ ../otherlibs/$(UNIXLIB)/unix.mli \ ../otherlibs/str/str.mli \ ../otherlibs/bigarray/bigarray.mli \ diff --git a/ocamldoc/odoc_args.ml b/ocamldoc/odoc_args.ml index be5ce12f..77b59025 100644 --- a/ocamldoc/odoc_args.ml +++ b/ocamldoc/odoc_args.ml @@ -172,29 +172,73 @@ let add_hidden_modules s = let set_generator (g : Odoc_gen.generator) = current_generator := Some g +let anonymous f = + let sf = + if Filename.check_suffix f "ml" then + Odoc_global.Impl_file f + else + if Filename.check_suffix f !Config.interface_suffix then + Odoc_global.Intf_file f + else + if Filename.check_suffix f "txt" then + Odoc_global.Text_file f + else + failwith (Odoc_messages.unknown_extension f) + in + Odoc_global.files := !Odoc_global.files @ [sf] + +module Options = Main_args.Make_ocamldoc_options(struct + let set r () = r := true + let unset r () = r := false + let _absname = set Location.absname + let _I s = Odoc_global.include_dirs := + (Misc.expand_directory Config.standard_library s) :: !Odoc_global.include_dirs + let _impl s = Odoc_global.files := !Odoc_global.files @ [Odoc_global.Impl_file s] + let _intf s = Odoc_global.files := !Odoc_global.files @ [Odoc_global.Intf_file s] + let _intf_suffix s = Config.interface_suffix := s + let _labels = unset Clflags.classic + let _no_alias_deps = set Clflags.transparent_modules + let _no_app_funct = unset Clflags.applicative_functors + let _noassert = set Clflags.noassert + let _nolabels = set Clflags.classic + let _nostdlib = set Clflags.no_std_include + let _open s = Clflags.open_modules := s :: !Clflags.open_modules + let _pp s = Clflags.preprocessor := Some s + let _ppx s = Clflags.all_ppx := s :: !Clflags.all_ppx + let _principal = set Clflags.principal + let _rectypes = set Clflags.recursive_types + let _safe_string = unset Clflags.unsafe_string + let _short_paths = unset Clflags.real_paths + let _strict_sequence = set Clflags.strict_sequence + let _strict_formats = set Clflags.strict_formats + let _thread = set Clflags.use_threads + let _vmthread = set Clflags.use_vmthreads + let _unsafe () = assert false + let _unsafe_string = set Clflags.unsafe_string + let _v () = Compenv.print_version_and_library "documentation generator" + let _version = Compenv.print_version_string + let _vnum = Compenv.print_version_string + let _w = (Warnings.parse_options false) + let _warn_error _ = assert false + let _warn_help _ = assert false + let _where = Compenv.print_standard_library + let _verbose = set Clflags.verbose + let _nopervasives = set Clflags.nopervasives + let _dsource = set Clflags.dump_source + let _dparsetree = set Clflags.dump_parsetree + let _dtypedtree = set Clflags.dump_typedtree + let _drawlambda = set Clflags.dump_rawlambda + let _dlambda = set Clflags.dump_lambda + let _dinstr = set Clflags.dump_instr + let anonymous = anonymous +end) + (** The default option list *) -let default_options = [ - "-version", Arg.Unit (fun () -> print_string M.message_version ; print_newline () ; exit 0) , M.option_version ; - "-vnum", Arg.Unit (fun () -> print_string M.config_version ; - print_newline () ; exit 0) , M.option_version ; - "-v", Arg.Unit (fun () -> Odoc_global.verbose := true), M.verbose_mode ; - "-I", Arg.String (fun s -> - Odoc_global.include_dirs := - (Misc.expand_directory Config.standard_library s) :: !Odoc_global.include_dirs), - M.include_dirs ; - "-pp", Arg.String (fun s -> Odoc_global.preprocessor := Some s), M.preprocess ; - "-ppx", Arg.String (fun s -> Odoc_global.ppx := s :: !Odoc_global.ppx), M.ppx ; - "-impl", Arg.String (fun s -> - Odoc_global.files := !Odoc_global.files @ [Odoc_global.Impl_file s]), - M.option_impl ; - "-intf", Arg.String (fun s -> - Odoc_global.files := !Odoc_global.files @ [Odoc_global.Intf_file s]), - M.option_intf ; +let default_options = Options.list @ +[ "-text", Arg.String (fun s -> Odoc_global.files := !Odoc_global.files @ [Odoc_global.Text_file s]), M.option_text ; - "-rectypes", Arg.Set Odoc_global.recursive_types, M.rectypes ; - "-nolabels", Arg.Unit (fun () -> Odoc_global.classic := true), M.nolabels ; "-warn-error", Arg.Set Odoc_global.warn_error, M.werr ; "-hide-warnings", Arg.Clear Odoc_config.print_warnings, M.hide_warnings ; "-o", Arg.String (fun s -> Odoc_global.out_file := s), M.out_file ; @@ -338,24 +382,9 @@ let add_option o = options := iter !options let parse () = - let anonymous f = - let sf = - if Filename.check_suffix f "ml" then - Odoc_global.Impl_file f - else - if Filename.check_suffix f "mli" then - Odoc_global.Intf_file f - else - if Filename.check_suffix f "txt" then - Odoc_global.Text_file f - else - failwith (Odoc_messages.unknown_extension f) - in - Odoc_global.files := !Odoc_global.files @ [sf] - in if modified_options () then append_last_doc "\n"; let options = !options @ !help_options in - let _ = Arg.parse options + let _ = Arg.parse (Arg.align ~limit:13 options) anonymous (M.usage^M.options_are) in diff --git a/ocamldoc/odoc_global.ml b/ocamldoc/odoc_global.ml index 901febf1..9c3efb98 100644 --- a/ocamldoc/odoc_global.ml +++ b/ocamldoc/odoc_global.ml @@ -40,13 +40,6 @@ let dump = ref (None : string option) let load = ref ([] : string list) -(** Allow arbitrary recursive types. *) -let recursive_types = Clflags.recursive_types - -(** Optional preprocessor command. *) -let preprocessor = Clflags.preprocessor -let ppx = Clflags.all_ppx - let sort_modules = ref false let no_custom_tags = ref false @@ -65,11 +58,9 @@ let hidden_modules = ref ([] : string list) let files = ref [] - - let out_file = ref Odoc_messages.default_out_file -let verbose = ref false +let verbose = Clflags.verbose let target_dir = ref Filename.current_dir_name diff --git a/ocamldoc/odoc_global.mli b/ocamldoc/odoc_global.mli index 2cf846c3..641d40c0 100644 --- a/ocamldoc/odoc_global.mli +++ b/ocamldoc/odoc_global.mli @@ -21,13 +21,6 @@ type source_file = (** The include_dirs in the OCaml compiler. *) val include_dirs : string list ref -(** Optional preprocessor command to pass to ocaml compiler. *) -val preprocessor : string option ref (* -pp *) -val ppx : string list ref (* -ppx *) - -(** Recursive types flag to passe to ocaml compiler. *) -val recursive_types : bool ref - (** The merge options to be used. *) val merge_options : Odoc_types.merge_option list ref diff --git a/ocamldoc/odoc_messages.ml b/ocamldoc/odoc_messages.ml index 4c409a3a..0ac45ba9 100644 --- a/ocamldoc/odoc_messages.ml +++ b/ocamldoc/odoc_messages.ml @@ -16,13 +16,11 @@ let ok = "Ok" let software = "OCamldoc" let config_version = Config.version let magic = config_version^"" -let message_version = software^" "^config_version (** Messages for command line *) let usage = "Usage: "^(Sys.argv.(0))^" [options] \n" let options_are = "Options are:" -let option_version = "\tPrint version and exit" let latex_only = "(LaTeX only)" let texi_only = "(TeXinfo only)" let latex_texi_only = "(LaTeX and TeXinfo only)" @@ -30,51 +28,45 @@ let html_only = "(HTML only)" let html_latex_only = "(HTML and LaTeX only)" let html_latex_texi_only = "(HTML, LaTeX and TeXinfo only)" let man_only = "(man only)" -let verbose_mode = "\t\tverbose mode" -let include_dirs = "\tAdd to the list of include directories" -let rectypes = "\tAllow arbitrary recursive types" -let preprocess = "\tPipe sources through preprocessor " -let ppx = "\n\t\tPipe abstract syntax tree through preprocessor " -let option_impl ="\tConsider as a .ml file" -let option_intf ="\tConsider as a .mli file" -let option_text ="\tConsider as a .txt file" -let display_custom_generators_dir = "\tDisplay custom generators standard directory and exit" -let add_load_dir = "\tAdd the given directory to the search path for custom\n"^ +let option_impl =" Consider as a .ml file" +let option_intf =" Consider as a .mli file" +let option_text =" Consider as a .txt file" +let display_custom_generators_dir = "Display custom generators standard directory and exit" +let add_load_dir = " Add the given directory to the search path for custom\n"^ "\t\tgenerators" -let load_file = "\n\t\tLoad file defining a new documentation generator" -let nolabels = "\tIgnore non-optional labels in types" -let werr = "\tTreat ocamldoc warnings as errors" -let hide_warnings = "\n\t\tdo not print ocamldoc warnings" -let target_dir = "\tGenerate files in directory , rather than in current\n"^ +let load_file = " Load file defining a new documentation generator" +let werr = " Treat ocamldoc warnings as errors" +let hide_warnings = " do not print ocamldoc warnings" +let target_dir = " Generate files in directory , rather than in current\n"^ "\t\tdirectory (for man and HTML generators)" -let dump = "\tDump collected information into " -let load = "\tLoad information from ; may be used several times" -let css_style = "\n\t\tUse content of as CSS style definition "^html_only -let index_only = "\tGenerate index files only "^html_only -let colorize_code = "\n\t\tColorize code even in documentation pages "^html_only -let html_short_functors = "\n\t\tUse short form to display functor types "^html_only +let dump = " Dump collected information into " +let load = " Load information from ; may be used several times" +let css_style = " Use content of as CSS style definition "^html_only +let index_only = " Generate index files only "^html_only +let colorize_code = " Colorize code even in documentation pages "^html_only +let html_short_functors = " Use short form to display functor types "^html_only let charset c = Printf.sprintf - "\n\t\tAdd information about character encoding being s\n\t\t(default is %s)" + " Add information about character encoding being s\n\t\t(default is %s)" c -let generate_html = "\tGenerate HTML documentation" -let generate_latex = "\tGenerate LaTeX documentation" -let generate_texinfo = "\tGenerate TeXinfo documentation" -let generate_man = "\t\tGenerate man pages" -let generate_dot = "\t\tGenerate dot code of top modules dependencies" +let generate_html = " Generate HTML documentation" +let generate_latex = " Generate LaTeX documentation" +let generate_texinfo = " Generate TeXinfo documentation" +let generate_man = " Generate man pages" +let generate_dot = " Generate dot code of top modules dependencies" let option_not_in_native_code op = "Option "^op^" not available in native code version." let default_out_file = "ocamldoc.out" let out_file = - "\tSet the output file name, used by texi, latex and dot generators\n"^ + " Set the output file name, used by texi, latex and dot generators\n"^ "\t\t(default is "^default_out_file^")\n"^ "\t\tor the prefix of index files for the HTML generator\n"^ "\t\t(default is index)" let dot_include_all = - "\n\t\tInclude all modules in the dot output, not only the\n"^ + " Include all modules in the dot output, not only the\n"^ "\t\tmodules given on the command line" -let dot_types = "\tGenerate dependency graph for types instead of modules" +let dot_types = " Generate dependency graph for types instead of modules" let default_dot_colors = [ [ "darkturquoise" ; "darkgoldenrod2" ; "cyan" ; "green" ; ] ; [ "magenta" ; "yellow" ; "burlywood1" ; "aquamarine" ; "floralwhite" ; "lightpink" ] ; @@ -82,36 +74,37 @@ let default_dot_colors = ] let dot_colors = - "\n\t\tUse colors c1,c1,...,cn in the dot output\n"^ + " \n"^ + "\t\tUse colors c1,c1,...,cn in the dot output\n"^ "\t\t(default list is "^ (String.concat ",\n\t\t" (List.map (String.concat ",") default_dot_colors))^")" let dot_reduce = - "\tPerform a transitive reduction on the selected dependency graph\n"^ + " Perform a transitive reduction on the selected dependency graph\n"^ "\t\tbefore the dot output" -let man_mini = "\tGenerate man pages only for modules, module types, classes\n"^ +let man_mini = " Generate man pages only for modules, module types, classes\n"^ "\t\tand class types "^man_only let default_man_section = "3" -let man_section = "
\n\t\tUse
in man page files "^ +let man_section = "
Use
in man page files "^ "(default is "^default_man_section^") "^man_only^"\n" let default_man_suffix = default_man_section^"o" -let man_suffix = "\n\t\tUse for man page files "^ +let man_suffix = " Use for man page files "^ "(default is "^default_man_suffix^") "^man_only^"\n" -let option_title = "\tUse <title> as title for the generated documentation" +let option_title = "<title> Use <title> as title for the generated documentation" let option_intro = - "<file>\tUse content of <file> as ocamldoc text to use as introduction\n"^ + "<file> Use content of <file> as ocamldoc text to use as introduction\n"^ "\t\t"^(html_latex_texi_only) -let with_parameter_list = "\tDisplay the complete list of parameters for functions and\n"^ +let with_parameter_list = " Display the complete list of parameters for functions and\n"^ "\t\tmethods "^html_only -let hide_modules = "<M1,M2.M3,...>\n\t\tHide the given complete module names in generated doc" -let no_header = "\tSuppress header in generated documentation\n\t\t"^latex_texi_only -let no_trailer = "\tSuppress trailer in generated documentation\n\t\t"^latex_texi_only -let separate_files = "\tGenerate one file per toplevel module "^latex_only +let hide_modules = "<M1,M2.M3,...> Hide the given complete module names in generated doc" +let no_header = " Suppress header in generated documentation\n\t\t"^latex_texi_only +let no_trailer = " Suppress trailer in generated documentation\n\t\t"^latex_texi_only +let separate_files = " Generate one file per toplevel module "^latex_only let latex_title ref_titles = - "n,style\n\t\tAssociate {n } to the given sectionning style\n"^ + "n,style Associate {n } to the given sectionning style\n"^ "\t\t(e.g. 'section') in the latex output "^latex_only^"\n"^ "\t\tDefault sectionning is:\n\t\t"^ (String.concat "\n\t\t" @@ -119,67 +112,78 @@ let latex_title ref_titles = let default_latex_value_prefix = "val:" let latex_value_prefix = - "<string>\n\t\tUse <string> as prefix for the LaTeX labels of values.\n"^ + "<string>\n"^ + "\t\tUse <string> as prefix for the LaTeX labels of values.\n"^ "\t\t(default is \""^default_latex_value_prefix^"\")" let default_latex_type_prefix = "type:" let latex_type_prefix = - "<string>\n\t\tUse <string> as prefix for the LaTeX labels of types.\n"^ + "<string>\n"^ + "\t\tUse <string> as prefix for the LaTeX labels of types.\n"^ "\t\t(default is \""^default_latex_type_prefix^"\")" let default_latex_type_elt_prefix = "typeelt:" let latex_type_elt_prefix = - "<string>\n\t\tUse <string> as prefix for the LaTeX labels of type elements.\n"^ + "<string>\n"^ + "\t\tUse <string> as prefix for the LaTeX labels of type elements.\n"^ "\t\t(default is \""^default_latex_type_elt_prefix^"\")" let default_latex_extension_prefix = "extension:" let latex_extension_prefix = - "<string>\n\t\tUse <string> as prefix for the LaTeX labels of extensions.\n"^ + "<string>\n"^ + "\t\tUse <string> as prefix for the LaTeX labels of extensions.\n"^ "\t\t(default is \""^default_latex_extension_prefix^"\")" let default_latex_exception_prefix = "exception:" let latex_exception_prefix = - "<string>\n\t\tUse <string> as prefix for the LaTeX labels of exceptions.\n"^ + "<string>\n"^ + "\t\tUse <string> as prefix for the LaTeX labels of exceptions.\n"^ "\t\t(default is \""^default_latex_exception_prefix^"\")" let default_latex_module_prefix = "module:" let latex_module_prefix = - "<string>\n\t\tUse <string> as prefix for the LaTeX labels of modules.\n"^ + "<string>\n"^ + "\t\tUse <string> as prefix for the LaTeX labels of modules.\n"^ "\t\t(default is \""^default_latex_module_prefix^"\")" let default_latex_module_type_prefix = "moduletype:" let latex_module_type_prefix = - "<string>\n\t\tUse <string> as prefix for the LaTeX labels of module types.\n"^ + "<string>\n"^ + "\t\tUse <string> as prefix for the LaTeX labels of module types.\n"^ "\t\t(default is \""^default_latex_module_type_prefix^"\")" let default_latex_class_prefix = "class:" let latex_class_prefix = - "<string>\n\t\tUse <string> as prefix for the LaTeX labels of classes.\n"^ + "<string>\n"^ + "\t\tUse <string> as prefix for the LaTeX labels of classes.\n"^ "\t\t(default is \""^default_latex_class_prefix^"\")" let default_latex_class_type_prefix = "classtype:" let latex_class_type_prefix = - "<string>\n\t\tUse <string> as prefix for the LaTeX labels of class types.\n"^ + "<string>\n"^ + "\t\tUse <string> as prefix for the LaTeX labels of class types.\n"^ "\t\t(default is \""^default_latex_class_type_prefix^"\")" let default_latex_attribute_prefix = "val:" let latex_attribute_prefix = - "<string>\n\t\tUse <string> as prefix for the LaTeX labels of attributes.\n"^ + "<string>\n"^ + "\t\tUse <string> as prefix for the LaTeX labels of attributes.\n"^ "\t\t(default is \""^default_latex_attribute_prefix^"\")" let default_latex_method_prefix = "method:" let latex_method_prefix = - "<string>\n\t\tUse <string> as prefix for the LaTeX labels of methods.\n"^ + "<string>\n"^ + "\t\tUse <string> as prefix for the LaTeX labels of methods.\n"^ "\t\t(default is \""^default_latex_method_prefix^"\")" -let no_toc = "\tDo not generate table of contents "^latex_only -let sort_modules = "\tSort the list of top modules before generating the documentation" -let no_stop = "\tDo not stop at (**/**) comments" -let no_custom_tags = "\n\t\tDo not allow custom @-tags" -let remove_stars = "\tRemove beginning blanks of comment lines, until the first '*'" -let keep_code = "\tAlways keep code when available" -let inverse_merge_ml_mli = "\n\t\tInverse implementations and interfaces when merging" -let no_filter_with_module_constraints = "\n\t\tDo not filter module elements using module type constraints" +let no_toc = " Do not generate table of contents "^latex_only +let sort_modules = " Sort the list of top modules before generating the documentation" +let no_stop = " Do not stop at (**/**) comments" +let no_custom_tags = " Do not allow custom @-tags" +let remove_stars = " Remove beginning blanks of comment lines, until the first '*'" +let keep_code = " Always keep code when available" +let inverse_merge_ml_mli = " Inverse implementations and interfaces when merging" +let no_filter_with_module_constraints = "Do not filter module elements using module type constraints" let merge_description = ('d', "merge description") let merge_author = ('a', "merge @author") let merge_version = ('v', "merge @version") @@ -193,10 +197,10 @@ let merge_return_value = ('r', "merge @return") let merge_custom = ('c', "merge custom @-tags") let merge_all = ('A', "merge all") -let no_index = "\tDo not build index for Info files "^texi_only -let esc_8bits = "\tEscape accentuated characters in Info files "^texi_only -let info_section = "Specify section of Info directory "^texi_only -let info_entry = "\tSpecify Info directory entry "^texi_only +let no_index = " Do not build index for Info files "^texi_only +let esc_8bits = " Escape accentuated characters in Info files "^texi_only +let info_section = " Specify section of Info directory "^texi_only +let info_entry = " Specify Info directory entry "^texi_only let options_can_be = "<options> can be one or more of the following characters:" let string_of_options_list l = @@ -205,7 +209,7 @@ let string_of_options_list l = l let merge_options = - "<options>\tspecify merge options between .mli and .ml\n\t\t"^ + "<options> specify merge options between .mli and .ml\n\t\t"^ options_can_be^ (string_of_options_list [ merge_description ; @@ -222,7 +226,7 @@ let merge_options = merge_all ] ) -let help = "\t\tDisplay this list of options" +let help = " Display this list of options" (** Error and warning messages *) diff --git a/otherlibs/systhreads/Makefile b/otherlibs/systhreads/Makefile index a08bf34b..f24af23b 100644 --- a/otherlibs/systhreads/Makefile +++ b/otherlibs/systhreads/Makefile @@ -31,7 +31,7 @@ all: libthreads.a threads.cma allopt: libthreadsnat.a threads.cmxa libthreads.a: $(BYTECODE_C_OBJS) - $(MKLIB) -o threads $(BYTECODE_C_OBJS) -lpthread + $(MKLIB) -o threads $(BYTECODE_C_OBJS) $(PTHREAD_LINK) st_stubs_b.o: st_stubs.c st_posix.h $(BYTECC) -O -I../../byterun $(BYTECCCOMPOPTS) $(SHAREDCCCOMPOPTS) \ @@ -51,12 +51,12 @@ st_stubs_n.o: st_stubs.c st_posix.h threads.cma: $(THREAD_OBJS) $(MKLIB) -ocamlc '$(CAMLC)' -o threads $(THREAD_OBJS) \ - -cclib -lunix $(PTHREAD_LINK) + -cclib -lunix $(PTHREAD_CAML_LINK) # See remark above: force static linking of libthreadsnat.a threads.cmxa: $(THREAD_OBJS:.cmo=.cmx) $(CAMLOPT) -a -o threads.cmxa $(THREAD_OBJS:.cmo=.cmx) \ - -cclib -lthreadsnat $(PTHREAD_LINK) + -cclib -lthreadsnat $(PTHREAD_CAML_LINK) # Note: I removed "-cclib -lunix" from the line above. # Indeed, if we link threads.cmxa, then we must also link unix.cmxa, diff --git a/otherlibs/threads/Makefile b/otherlibs/threads/Makefile index 1c4434f5..4b783333 100644 --- a/otherlibs/threads/Makefile +++ b/otherlibs/threads/Makefile @@ -27,21 +27,21 @@ CAML_OBJS=thread.cmo mutex.cmo condition.cmo event.cmo threadUnix.cmo LIB=../../stdlib -LIB_OBJS=$(LIB)/camlinternalFormatBasics.cmo pervasives.cmo \ - $(LIB)/array.cmo $(LIB)/list.cmo $(LIB)/char.cmo $(LIB)/string.cmo \ - $(LIB)/sys.cmo $(LIB)/sort.cmo marshal.cmo $(LIB)/obj.cmo \ - $(LIB)/int32.cmo $(LIB)/int64.cmo $(LIB)/nativeint.cmo \ - $(LIB)/lexing.cmo $(LIB)/parsing.cmo $(LIB)/set.cmo $(LIB)/map.cmo \ - $(LIB)/stack.cmo $(LIB)/queue.cmo $(LIB)/camlinternalLazy.cmo \ - $(LIB)/lazy.cmo $(LIB)/stream.cmo $(LIB)/buffer.cmo \ - $(LIB)/printf.cmo $(LIB)/arg.cmo $(LIB)/printexc.cmo $(LIB)/gc.cmo \ - $(LIB)/digest.cmo $(LIB)/random.cmo $(LIB)/hashtbl.cmo \ - $(LIB)/format.cmo $(LIB)/scanf.cmo $(LIB)/callback.cmo \ - $(LIB)/camlinternalOO.cmo \ - $(LIB)/oo.cmo $(LIB)/camlinternalMod.cmo $(LIB)/genlex.cmo \ - $(LIB)/weak.cmo $(LIB)/filename.cmo \ - $(LIB)/complex.cmo $(LIB)/arrayLabels.cmo $(LIB)/listLabels.cmo \ - $(LIB)/stringLabels.cmo $(LIB)/stdLabels.cmo $(LIB)/moreLabels.cmo +LIB_OBJS=$(LIB)/camlinternalFormatBasics.cmo pervasives.cmo \ + $(LIB)/array.cmo $(LIB)/list.cmo $(LIB)/char.cmo $(LIB)/bytes.cmo \ + $(LIB)/string.cmo $(LIB)/sys.cmo $(LIB)/sort.cmo $(LIB)/marshal.cmo \ + $(LIB)/obj.cmo $(LIB)/int32.cmo $(LIB)/int64.cmo \ + $(LIB)/nativeint.cmo $(LIB)/lexing.cmo $(LIB)/parsing.cmo \ + $(LIB)/set.cmo $(LIB)/map.cmo $(LIB)/stack.cmo $(LIB)/queue.cmo \ + $(LIB)/camlinternalLazy.cmo $(LIB)/lazy.cmo $(LIB)/stream.cmo \ + $(LIB)/buffer.cmo $(LIB)/camlinternalFormat.cmo $(LIB)/printf.cmo \ + $(LIB)/arg.cmo $(LIB)/printexc.cmo $(LIB)/gc.cmo $(LIB)/digest.cmo \ + $(LIB)/random.cmo $(LIB)/hashtbl.cmo $(LIB)/format.cmo \ + $(LIB)/scanf.cmo $(LIB)/callback.cmo $(LIB)/camlinternalOO.cmo \ + $(LIB)/oo.cmo $(LIB)/camlinternalMod.cmo $(LIB)/genlex.cmo \ + $(LIB)/weak.cmo $(LIB)/filename.cmo $(LIB)/complex.cmo \ + $(LIB)/arrayLabels.cmo $(LIB)/listLabels.cmo $(LIB)/bytesLabels.cmo \ + $(LIB)/stringLabels.cmo $(LIB)/moreLabels.cmo $(LIB)/stdLabels.cmo UNIXLIB=../unix diff --git a/otherlibs/unix/nice.c b/otherlibs/unix/nice.c index 019e2d1c..d0956a16 100644 --- a/otherlibs/unix/nice.c +++ b/otherlibs/unix/nice.c @@ -22,7 +22,11 @@ CAMLprim value unix_nice(value incr) { int ret; errno = 0; +#ifdef HAS_NICE ret = nice(Int_val(incr)); +#else + ret = 0; +#endif if (ret == -1 && errno != 0) uerror("nice", Nothing); return Val_int(ret); } diff --git a/parsing/ast_mapper.ml b/parsing/ast_mapper.ml index f44b1233..669d0144 100644 --- a/parsing/ast_mapper.ml +++ b/parsing/ast_mapper.ml @@ -19,7 +19,6 @@ open Asttypes -open Longident open Parsetree open Ast_helper open Location @@ -625,79 +624,170 @@ let attribute_of_warning loc s = { loc; txt = "ocaml.ppwarning" }, PStr ([Str.eval ~loc (Exp.constant (Const_string (s, None)))]) +module StringMap = Map.Make(struct + type t = string + let compare = compare +end) + +let cookies = ref StringMap.empty + +let get_cookie k = + try Some (StringMap.find k !cookies) + with Not_found -> None + +let set_cookie k v = + cookies := StringMap.add k v !cookies + let tool_name_ref = ref "_none_" let tool_name () = !tool_name_ref -let restore_ppx_context payload = - let fields = - match payload with + +module PpxContext = struct + open Longident + open Asttypes + open Ast_helper + + let lid name = { txt = Lident name; loc = Location.none } + + let make_string x = Exp.constant (Const_string (x, None)) + + let make_bool x = + if x + then Exp.construct (lid "true") None + else Exp.construct (lid "false") None + + let rec make_list f lst = + match lst with + | x :: rest -> + Exp.construct (lid "::") (Some (Exp.tuple [f x; make_list f rest])) + | [] -> + Exp.construct (lid "[]") None + + let make_pair f1 f2 (x1, x2) = + Exp.tuple [f1 x1; f2 x2] + + let make_option f opt = + match opt with + | Some x -> Exp.construct (lid "Some") (Some (f x)) + | None -> Exp.construct (lid "None") None + + let get_cookies () = + lid "cookies", + make_list (make_pair make_string (fun x -> x)) + (StringMap.bindings !cookies) + + let mk fields = + { txt = "ocaml.ppx.context"; loc = Location.none }, + Parsetree.PStr [Str.eval (Exp.record fields None)] + + let make ~tool_name () = + let fields = + [ + lid "tool_name", make_string tool_name; + lid "include_dirs", make_list make_string !Clflags.include_dirs; + lid "load_path", make_list make_string !Config.load_path; + lid "open_modules", make_list make_string !Clflags.open_modules; + lid "for_package", make_option make_string !Clflags.for_package; + lid "debug", make_bool !Clflags.debug; + get_cookies () + ] + in + mk fields + + let get_fields = function | PStr [{pstr_desc = Pstr_eval ({ pexp_desc = Pexp_record (fields, None) }, [])}] -> fields | _ -> raise_errorf "Internal error: invalid [@@@ocaml.ppx.context] syntax" - in - let field name payload = - let rec get_string = function - | { pexp_desc = Pexp_constant (Const_string (str, None)) } -> str - | _ -> - raise_errorf - "Internal error: invalid [@@@ocaml.ppx.context { %s }] string syntax" - name - and get_bool pexp = - match pexp with - | {pexp_desc = Pexp_construct ({txt = Longident.Lident "true"}, None)} -> - true - | {pexp_desc = Pexp_construct ({txt = Longident.Lident "false"}, None)} -> - false - | _ -> - raise_errorf - "Internal error: invalid [@@@ocaml.ppx.context { %s }] bool syntax" - name - and get_list elem = function - | {pexp_desc = - Pexp_construct ({txt = Longident.Lident "::"}, - Some {pexp_desc = Pexp_tuple [exp; rest]}) } -> - elem exp :: get_list elem rest - | {pexp_desc = - Pexp_construct ({txt = Longident.Lident "[]"}, None)} -> - [] - | _ -> - raise_errorf - "Internal error: invalid [@@@ocaml.ppx.context { %s }] list syntax" - name - and get_option elem = function - | { pexp_desc = - Pexp_construct ({ txt = Longident.Lident "Some" }, Some exp) } -> - Some (elem exp) - | { pexp_desc = - Pexp_construct ({ txt = Longident.Lident "None" }, None) } -> - None + + let restore fields = + let field name payload = + let rec get_string = function + | { pexp_desc = Pexp_constant (Const_string (str, None)) } -> str + | _ -> + raise_errorf + "Internal error: invalid [@@@ocaml.ppx.context { %s }] string syntax" + name + and get_bool pexp = + match pexp with + | {pexp_desc = Pexp_construct ({txt = Longident.Lident "true"}, None)} -> + true + | {pexp_desc = Pexp_construct ({txt = Longident.Lident "false"}, None)} -> + false + | _ -> + raise_errorf + "Internal error: invalid [@@@ocaml.ppx.context { %s }] bool syntax" + name + and get_list elem = function + | {pexp_desc = + Pexp_construct ({txt = Longident.Lident "::"}, + Some {pexp_desc = Pexp_tuple [exp; rest]}) } -> + elem exp :: get_list elem rest + | {pexp_desc = + Pexp_construct ({txt = Longident.Lident "[]"}, None)} -> + [] + | _ -> + raise_errorf + "Internal error: invalid [@@@ocaml.ppx.context { %s }] list syntax" + name + and get_pair f1 f2 = function + | {pexp_desc = Pexp_tuple [e1; e2]} -> + (f1 e1, f2 e2) + | _ -> + raise_errorf + "Internal error: invalid [@@@ocaml.ppx.context { %s }] pair syntax" + name + and get_option elem = function + | { pexp_desc = + Pexp_construct ({ txt = Longident.Lident "Some" }, Some exp) } -> + Some (elem exp) + | { pexp_desc = + Pexp_construct ({ txt = Longident.Lident "None" }, None) } -> + None + | _ -> + raise_errorf + "Internal error: invalid [@@@ocaml.ppx.context { %s }] option syntax" + name + in + match name with + | "tool_name" -> + tool_name_ref := get_string payload + | "include_dirs" -> + Clflags.include_dirs := get_list get_string payload + | "load_path" -> + Config.load_path := get_list get_string payload + | "open_modules" -> + Clflags.open_modules := get_list get_string payload + | "for_package" -> + Clflags.for_package := get_option get_string payload + | "debug" -> + Clflags.debug := get_bool payload + | "cookies" -> + let l = get_list (get_pair get_string (fun x -> x)) payload in + cookies := + List.fold_left + (fun s (k, v) -> StringMap.add k v s) StringMap.empty + l | _ -> - raise_errorf - "Internal error: invalid [@@@ocaml.ppx.context { %s }] option syntax" - name + () in - match name with - | "tool_name" -> - tool_name_ref := get_string payload - | "include_dirs" -> - Clflags.include_dirs := get_list get_string payload - | "load_path" -> - Config.load_path := get_list get_string payload - | "open_modules" -> - Clflags.open_modules := get_list get_string payload - | "for_package" -> - Clflags.for_package := get_option get_string payload - | "debug" -> - Clflags.debug := get_bool payload - | _ -> - () - in - List.iter (function ({txt=Lident name}, x) -> field name x | _ -> ()) fields + List.iter (function ({txt=Lident name}, x) -> field name x | _ -> ()) fields -let apply ~source ~target mapper = + let update_cookies fields = + let fields = + List.filter + (function ({txt=Lident "cookies"}, _) -> false | _ -> true) + fields + in + fields @ [get_cookies ()] +end + +let ppx_context = PpxContext.make + + +let apply_lazy ~source ~target mapper = let ic = open_in_bin source in let magic = really_input_string ic (String.length Config.ast_impl_magic_number) @@ -711,12 +801,17 @@ let apply ~source ~target mapper = let implem ast = try - begin match ast with - | {pstr_desc = Pstr_attribute ({txt = "ocaml.ppx.context"}, x)} :: _ -> - restore_ppx_context x - | _ -> () - end; - mapper.structure mapper ast + let fields, ast = + match ast with + | {pstr_desc = Pstr_attribute ({txt = "ocaml.ppx.context"}, x)} :: l -> + PpxContext.get_fields x, l + | _ -> [], ast + in + PpxContext.restore fields; + let mapper = mapper () in + let ast = mapper.structure mapper ast in + let fields = PpxContext.update_cookies fields in + Str.attribute (PpxContext.mk fields) :: ast with exn -> match error_of_exn exn with | Some error -> @@ -726,12 +821,17 @@ let apply ~source ~target mapper = in let iface ast = try - begin match ast with - | {psig_desc = Psig_attribute ({txt = "ocaml.ppx.context"}, x)} :: _ -> - restore_ppx_context x - | _ -> () - end; - mapper.signature mapper ast + let fields, ast = + match ast with + | {psig_desc = Psig_attribute ({txt = "ocaml.ppx.context"}, x)} :: l -> + PpxContext.get_fields x, l + | _ -> [], ast + in + PpxContext.restore fields; + let mapper = mapper () in + let ast = mapper.signature mapper ast in + let fields = PpxContext.update_cookies fields in + Sig.attribute (PpxContext.mk fields) :: ast with exn -> match error_of_exn exn with | Some error -> @@ -750,19 +850,45 @@ let apply ~source ~target mapper = output_value oc ast; close_out oc +let drop_ppx_context_str ~restore = function + | {pstr_desc = Pstr_attribute({Location.txt = "ocaml.ppx.context"}, a)} + :: items -> + if restore then + PpxContext.restore (PpxContext.get_fields a); + items + | items -> items + +let drop_ppx_context_sig ~restore = function + | {psig_desc = Psig_attribute({Location.txt = "ocaml.ppx.context"}, a)} + :: items -> + if restore then + PpxContext.restore (PpxContext.get_fields a); + items + | items -> items + +let add_ppx_context_str ~tool_name ast = + Ast_helper.Str.attribute (ppx_context ~tool_name ()) :: ast + +let add_ppx_context_sig ~tool_name ast = + Ast_helper.Sig.attribute (ppx_context ~tool_name ()) :: ast + + +let apply ~source ~target mapper = + apply_lazy ~source ~target (fun () -> mapper) + let run_main mapper = try let a = Sys.argv in let n = Array.length a in if n > 2 then - let mapper = + let mapper () = try mapper (Array.to_list (Array.sub a 1 (n - 3))) with exn -> (* PR #6463 *) let f _ _ = raise exn in {default_mapper with structure = f; signature = f} in - apply ~source:a.(n - 2) ~target:a.(n - 1) mapper + apply_lazy ~source:a.(n - 2) ~target:a.(n - 1) mapper else begin Printf.eprintf "Usage: %s [extra_args] <infile> <outfile>\n%!" Sys.executable_name; @@ -774,38 +900,3 @@ let run_main mapper = let register_function = ref (fun _name f -> run_main f) let register name f = !register_function name f - - -let ppx_context ~tool_name () = - let open Longident in - let open Asttypes in - let open Ast_helper in - let lid name = { txt = Lident name; loc = Location.none } in - let make_string x = Exp.constant (Const_string (x, None)) in - let make_bool x = - if x - then Exp.construct (lid "true") None - else Exp.construct (lid "false") None - in - let rec make_list f lst = - match lst with - | x :: rest -> - Exp.construct (lid "::") (Some (Exp.tuple [f x; make_list f rest])) - | [] -> - Exp.construct (lid "[]") None - in - let make_option f opt = - match opt with - | Some x -> Exp.construct (lid "Some") (Some (f x)) - | None -> Exp.construct (lid "None") None - in - { txt = "ocaml.ppx.context"; loc = Location.none }, - Parsetree.PStr [Str.eval ( - Exp.record ([ - lid "tool_name", make_string tool_name; - lid "include_dirs", make_list make_string !Clflags.include_dirs; - lid "load_path", make_list make_string !Config.load_path; - lid "open_modules", make_list make_string !Clflags.open_modules; - lid "for_package", make_option make_string !Clflags.for_package; - lid "debug", make_bool !Clflags.debug; - ]) None)] diff --git a/parsing/ast_mapper.mli b/parsing/ast_mapper.mli index 786c37d6..d48971d5 100644 --- a/parsing/ast_mapper.mli +++ b/parsing/ast_mapper.mli @@ -10,7 +10,40 @@ (* *) (***********************************************************************) -(** Helpers to write Parsetree rewriters *) +(** The interface of a -ppx rewriter + + A -ppx rewriter is a program that accepts a serialized abstract syntax + tree and outputs another, possibly modified, abstract syntax tree. + This module encapsulates the interface between the compiler and + the -ppx rewriters, handling such details as the serialization format, + forwarding of command-line flags, and storing state. + + {!mapper} allows to implement AST rewriting using open recursion. + A typical mapper would be based on {!default_mapper}, a deep + identity mapper, and will fall back on it for handling the syntax it + does not modify. For example: + + {[ +open Asttypes +open Parsetree +open Ast_mapper + +let test_mapper argv = + { default_mapper with + expr = fun mapper expr -> + match expr with + | { pexp_desc = Pexp_extension ({ txt = "test" }, PStr [])} -> + Ast_helper.Exp.constant (Const_int 42) + | other -> default_mapper.expr mapper other; } + +let () = + register "ppx_test" test_mapper]} + + This -ppx rewriter, which replaces [[%test]] in expressions with + the constant [42], can be compiled using + [ocamlc -o ppx_test -I +compiler-libs ocamlcommon.cma ppx_test.ml]. + + *) open Parsetree @@ -100,7 +133,6 @@ val run_main: (string list -> mapper) -> unit val register_function: (string -> (string list -> mapper) -> unit) ref val register: string -> (string list -> mapper) -> unit - (** Apply the [register_function]. The default behavior is to run the mapper immediately, taking arguments from the process command line. This is to support a scenario where a mapper is linked as a @@ -134,8 +166,28 @@ val attribute_of_warning: Location.t -> string -> attribute (** {2 Helper functions to call external mappers} *) -val ppx_context: tool_name:string -> unit -> Parsetree.attribute +val add_ppx_context_str: tool_name:string -> Parsetree.structure -> Parsetree.structure (** Extract information from the current environment and encode it - into an attribute an attribute which can be prepended to - signature/structure items of an AST to pass the information to an - external processor. *) + into an attribute which is prepended to the list of structure + items in order to pass the information to an external + processor. *) + +val add_ppx_context_sig: tool_name:string -> Parsetree.signature -> Parsetree.signature +(** Same as [add_ppx_context_str], but for signatures. *) + +val drop_ppx_context_str: restore:bool -> Parsetree.structure -> Parsetree.structure +(** Drop the ocaml.ppx.context attribute from a structure. If + [restore] is true, also restore the associated data in the current + process. *) + +val drop_ppx_context_sig: restore:bool -> Parsetree.signature -> Parsetree.signature +(** Same as [drop_ppx_context_str], but for signatures. *) + +(** {2 Cookies} *) + +(** Cookies are used to pass information from a ppx processor to + a further invocation of itself, when called from the OCaml + toplevel (or other tools that support cookies). *) + +val set_cookie: string -> Parsetree.expression -> unit +val get_cookie: string -> Parsetree.expression option diff --git a/parsing/location.ml b/parsing/location.ml index c6d1704f..174377ee 100644 --- a/parsing/location.ml +++ b/parsing/location.ml @@ -363,10 +363,15 @@ let () = ) -let report_exception ppf exn = - match error_of_exn exn with - | Some err -> fprintf ppf "@[%a@]@." report_error err +let rec report_exception_rec n ppf exn = + try match error_of_exn exn with + | Some err -> + fprintf ppf "@[%a@]@." report_error err | None -> raise exn + with exn when n > 0 -> + report_exception_rec (n-1) ppf exn + +let report_exception ppf exn = report_exception_rec 5 ppf exn exception Error of error diff --git a/parsing/parser.mly b/parsing/parser.mly index 4e2053be..ba8e98e6 100644 --- a/parsing/parser.mly +++ b/parsing/parser.mly @@ -547,7 +547,7 @@ parse_pattern: functor_arg: LPAREN RPAREN - { mkrhs "()" 2, None } + { mkrhs "*" 2, None } | LPAREN functor_arg_name COLON module_type RPAREN { mkrhs $2 2, Some $4 } ; @@ -776,7 +776,7 @@ module_declaration: | LPAREN UIDENT COLON module_type RPAREN module_declaration { mkmty(Pmty_functor(mkrhs $2 2, Some $4, $6)) } | LPAREN RPAREN module_declaration - { mkmty(Pmty_functor(mkrhs "()" 1, None, $3)) } + { mkmty(Pmty_functor(mkrhs "*" 1, None, $3)) } ; module_rec_declarations: module_rec_declaration { [$1] } diff --git a/parsing/pprintast.ml b/parsing/pprintast.ml index ad1e5daa..7dea70c5 100644 --- a/parsing/pprintast.ml +++ b/parsing/pprintast.ml @@ -351,7 +351,7 @@ class printer ()= object(self:'self) | p -> self#pattern1 f p in if x.ppat_attributes <> [] then self#pattern f x else match x.ppat_desc with - | Ppat_variant (l, Some p) -> pp f "@[<2>`%s@;%a@]" l self#pattern1 p (*RA*) + | Ppat_variant (l, Some p) -> pp f "@[<2>`%s@;%a@]" l self#simple_pattern p | Ppat_construct (({txt=Lident("()"|"[]");_}), _) -> self#simple_pattern f x | Ppat_construct (({txt;_} as li), po) -> (* FIXME The third field always false *) if txt = Lident "::" then diff --git a/stdlib/arg.ml b/stdlib/arg.ml index 0f6480b8..d7b8ac0b 100644 --- a/stdlib/arg.ml +++ b/stdlib/arg.ml @@ -255,18 +255,24 @@ let add_padding len ksd = ksd | (kwd, (Symbol (l, _) as spec), msg) -> let cutcol = second_word msg in - let spaces = String.make (len - cutcol + 3) ' ' in + let spaces = String.make ((max 0 (len - cutcol)) + 3) ' ' in (kwd, spec, "\n" ^ spaces ^ msg) | (kwd, spec, msg) -> let cutcol = second_word msg in - let spaces = String.make (len - String.length kwd - cutcol) ' ' in - let prefix = String.sub msg 0 cutcol in - let suffix = String.sub msg cutcol (String.length msg - cutcol) in - (kwd, spec, prefix ^ spaces ^ suffix) + let kwd_len = String.length kwd in + let diff = len - kwd_len - cutcol in + if diff <= 0 then + (kwd, spec, msg) + else + let spaces = String.make diff ' ' in + let prefix = String.sub msg 0 cutcol in + let suffix = String.sub msg cutcol (String.length msg - cutcol) in + (kwd, spec, prefix ^ spaces ^ suffix) ;; -let align speclist = +let align ?(limit=max_int) speclist = let completed = add_help speclist in let len = List.fold_left max_arg_len 0 completed in + let len = min len limit in List.map (add_padding len) completed ;; diff --git a/stdlib/arg.mli b/stdlib/arg.mli index 22eda40b..0999edf5 100644 --- a/stdlib/arg.mli +++ b/stdlib/arg.mli @@ -140,12 +140,15 @@ val usage_string : (key * spec * doc) list -> usage_msg -> string (** Returns the message that would have been printed by {!Arg.usage}, if provided with the same parameters. *) -val align: (key * spec * doc) list -> (key * spec * doc) list;; +val align: ?limit: int -> (key * spec * doc) list -> (key * spec * doc) list;; (** Align the documentation strings by inserting spaces at the first space, according to the length of the keyword. Use a space as the first character in a doc string if you want to align the whole string. The doc strings corresponding to - [Symbol] arguments are aligned on the next line. *) + [Symbol] arguments are aligned on the next line. + @param limit options with keyword and message longer than + [limit] will not be used to compute the alignement. +*) val current : int ref (** Position (in {!Sys.argv}) of the argument being processed. You can diff --git a/stdlib/array.mli b/stdlib/array.mli index e9a64528..99de0c80 100644 --- a/stdlib/array.mli +++ b/stdlib/array.mli @@ -47,7 +47,7 @@ external make : int -> 'a -> 'a array = "caml_make_vect" size is only [Sys.max_array_length / 2].*) external create : int -> 'a -> 'a array = "caml_make_vect" - [@@ocaml.deprecated] + [@@ocaml.deprecated "Use Array.make instead."] (** @deprecated [Array.create] is an alias for {!Array.make}. *) val init : int -> (int -> 'a) -> 'a array @@ -74,7 +74,7 @@ val make_matrix : int -> int -> 'a -> 'a array array size is only [Sys.max_array_length / 2]. *) val create_matrix : int -> int -> 'a -> 'a array array - [@@ocaml.deprecated] + [@@ocaml.deprecated "Use Array.make_matrix instead."] (** @deprecated [Array.create_matrix] is an alias for {!Array.make_matrix}. *) val append : 'a array -> 'a array -> 'a array diff --git a/stdlib/arrayLabels.mli b/stdlib/arrayLabels.mli index cf8b650e..0d046378 100644 --- a/stdlib/arrayLabels.mli +++ b/stdlib/arrayLabels.mli @@ -47,7 +47,7 @@ external make : int -> 'a -> 'a array = "caml_make_vect" size is only [Sys.max_array_length / 2].*) external create : int -> 'a -> 'a array = "caml_make_vect" - [@@ocaml.deprecated] + [@@ocaml.deprecated "Use ArrayLabels.make instead."] (** @deprecated [ArrayLabels.create] is an alias for {!ArrayLabels.make}. *) val init : int -> f:(int -> 'a) -> 'a array @@ -74,7 +74,7 @@ val make_matrix : dimx:int -> dimy:int -> 'a -> 'a array array size is only [Sys.max_array_length / 2]. *) val create_matrix : dimx:int -> dimy:int -> 'a -> 'a array array - [@@ocaml.deprecated] + [@@ocaml.deprecated "Use ArrayLabels.make_matrix instead."] (** @deprecated [ArrayLabels.create_matrix] is an alias for {!ArrayLabels.make_matrix}. *) diff --git a/stdlib/bytes.ml b/stdlib/bytes.ml index ece7c1ea..ce6e126d 100644 --- a/stdlib/bytes.ml +++ b/stdlib/bytes.ml @@ -55,7 +55,7 @@ let of_string s = copy (unsafe_of_string s) let sub s ofs len = if ofs < 0 || len < 0 || ofs > length s - len - then invalid_arg "Bytes.sub" + then invalid_arg "String.sub / Bytes.sub" else begin let r = create len in unsafe_blit s ofs r 0 len; @@ -74,7 +74,7 @@ let extend s left right = let fill s ofs len c = if ofs < 0 || len < 0 || ofs > length s - len - then invalid_arg "Bytes.fill" + then invalid_arg "String.fill / Bytes.fill" else unsafe_fill s ofs len c let blit s1 ofs1 s2 ofs2 len = @@ -86,7 +86,7 @@ let blit s1 ofs1 s2 ofs2 len = let blit_string s1 ofs1 s2 ofs2 len = if len < 0 || ofs1 < 0 || ofs1 > string_length s1 - len || ofs2 < 0 || ofs2 > length s2 - len - then invalid_arg "Bytes.blit_string" + then invalid_arg "String.blit / Bytes.blit_string" else unsafe_blit_string s1 ofs1 s2 ofs2 len let iter f a = @@ -224,7 +224,7 @@ let index s c = index_rec s (length s) 0 c;; let index_from s i c = let l = length s in - if i < 0 || i > l then invalid_arg "Bytes.index_from" else + if i < 0 || i > l then invalid_arg "String.index_from / Bytes.index_from" else index_rec s l i c;; let rec rindex_rec s i c = @@ -234,19 +234,28 @@ let rec rindex_rec s i c = let rindex s c = rindex_rec s (length s - 1) c;; let rindex_from s i c = - if i < -1 || i >= length s then invalid_arg "Bytes.rindex_from" else - rindex_rec s i c;; + if i < -1 || i >= length s then + invalid_arg "String.rindex_from / Bytes.rindex_from" + else + rindex_rec s i c +;; let contains_from s i c = let l = length s in - if i < 0 || i > l then invalid_arg "Bytes.contains_from" else - try ignore (index_rec s l i c); true with Not_found -> false;; + if i < 0 || i > l then + invalid_arg "String.contains_from / Bytes.contains_from" + else + try ignore (index_rec s l i c); true with Not_found -> false +;; let contains s c = contains_from s 0 c;; let rcontains_from s i c = - if i < 0 || i >= length s then invalid_arg "Bytes.rcontains_from" else - try ignore (rindex_rec s i c); true with Not_found -> false;; + if i < 0 || i >= length s then + invalid_arg "String.rcontains_from / Bytes.rcontains_from" + else + try ignore (rindex_rec s i c); true with Not_found -> false +;; type t = bytes diff --git a/stdlib/camlinternalFormat.ml b/stdlib/camlinternalFormat.ml index 5dda3a7f..40d76678 100644 --- a/stdlib/camlinternalFormat.ml +++ b/stdlib/camlinternalFormat.ml @@ -94,6 +94,8 @@ fun ign fmt -> match ign with Param_format_EBB (Scan_char_set (width_opt, char_set, fmt)) | Ignored_scan_get_counter counter -> Param_format_EBB (Scan_get_counter (counter, fmt)) + | Ignored_scan_next_char -> + Param_format_EBB (Scan_next_char fmt) (******************************************************************************) @@ -568,6 +570,10 @@ let bprint_fmt buf fmt = buffer_add_char buf '%'; bprint_ignored_flag buf ign_flag; buffer_add_char buf (char_of_counter counter); fmtiter rest false; + | Scan_next_char rest -> + buffer_add_char buf '%'; bprint_ignored_flag buf ign_flag; + bprint_string_literal buf "0c"; fmtiter rest false; + | Ignored_param (ign, rest) -> let Param_format_EBB fmt' = param_format_of_ignored_format ign rest in fmtiter fmt' true; @@ -842,6 +848,7 @@ fun fmtty -> match fmtty with | Scan_char_set (_, _, rest) -> String_ty (fmtty_of_fmt rest) | Scan_get_counter (_, rest) -> Int_ty (fmtty_of_fmt rest) + | Scan_next_char rest -> Char_ty (fmtty_of_fmt rest) | Ignored_param (ign, rest) -> fmtty_of_ignored_format ign rest | Formatting_lit (_, rest) -> fmtty_of_fmt rest | Formatting_gen (fmting_gen, rest) -> @@ -871,6 +878,7 @@ fun ign fmt -> match ign with | Ignored_reader -> Ignored_reader_ty (fmtty_of_fmt fmt) | Ignored_scan_char_set _ -> fmtty_of_fmt fmt | Ignored_scan_get_counter _ -> fmtty_of_fmt fmt + | Ignored_scan_next_char -> fmtty_of_fmt fmt (* Add an Int_ty node if padding is taken as an extra argument (ex: "%*s"). *) and fmtty_of_padding_fmtty : type x a b c d e f . @@ -1067,7 +1075,7 @@ fun formatting_gen fmt0 fmtty0 -> match formatting_gen with | Open_box (Format (fmt1, str)) -> let Fmt_fmtty_EBB (fmt2, fmtty2) = type_format_gen fmt1 fmtty0 in let Fmt_fmtty_EBB (fmt3, fmtty3) = type_format_gen fmt0 fmtty2 in - Fmt_fmtty_EBB (Formatting_gen (Open_tag (Format (fmt2, str)), fmt3), fmtty3) + Fmt_fmtty_EBB (Formatting_gen (Open_box (Format (fmt2, str)), fmt3), fmtty3) (* Type an Ignored_param node according to an fmtty. *) and type_ignored_param : type p q x y z t u v a b c d e f . @@ -1088,6 +1096,7 @@ fun ign fmt fmtty -> match ign with | Ignored_bool as ign' -> type_ignored_param_one ign' fmt fmtty | Ignored_scan_char_set _ as ign' -> type_ignored_param_one ign' fmt fmtty | Ignored_scan_get_counter _ as ign' -> type_ignored_param_one ign' fmt fmtty + | Ignored_scan_next_char as ign' -> type_ignored_param_one ign' fmt fmtty | Ignored_format_arg (pad_opt, sub_fmtty) -> type_ignored_param_one (Ignored_format_arg (pad_opt, sub_fmtty)) fmt fmtty | Ignored_format_subst (pad_opt, sub_fmtty) -> @@ -1229,6 +1238,18 @@ let recast : (* Add padding spaces arround a string. *) let fix_padding padty width str = let len = String.length str in + let width, padty = + abs width, + (* while literal padding widths are always non-negative, + dynamically-set widths (Arg_padding, eg. %*d) may be negative; + we interpret those as specifying a padding-to-the-left; this + means that '0' may get dropped even if it was explicitly set, + but: + - this is what the legacy implementation does, and + we preserve compatibility if possible + - we could only signal this issue by failing at runtime, + which is not very nice... *) + if width < 0 then Left else padty in if width <= len then str else let res = Bytes.make width (if padty = Zeros then '0' else ' ') in begin match padty with @@ -1247,22 +1268,25 @@ let fix_padding padty width str = (* Add '0' padding to int, int32, nativeint or int64 string representation. *) let fix_int_precision prec str = + let prec = abs prec in let len = String.length str in - if prec <= len then str else + match str.[0] with + | ('+' | '-' | ' ') as c when prec + 1 > len -> + let res = Bytes.make (prec + 1) '0' in + Bytes.set res 0 c; + String.blit str 1 res (prec - len + 2) (len - 1); + Bytes.unsafe_to_string res + | '0' when prec + 2 > len && len > 1 && (str.[1] = 'x' || str.[1] = 'X') -> + let res = Bytes.make (prec + 2) '0' in + Bytes.set res 1 str.[1]; + String.blit str 2 res (prec - len + 4) (len - 2); + Bytes.unsafe_to_string res + | '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' when prec > len -> let res = Bytes.make prec '0' in - begin match str.[0] with - | ('+' | '-' | ' ') as c -> - Bytes.set res 0 c; - String.blit str 1 res (prec - len + 1) (len - 1); - | '0' when len > 1 && (str.[1] = 'x' || str.[1] = 'X') -> - Bytes.set res 1 str.[1]; - String.blit str 2 res (prec - len + 2) (len - 2); - | '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' -> - String.blit str 0 res (prec - len) len; - | _ -> - assert false - end; + String.blit str 0 res (prec - len) len; Bytes.unsafe_to_string res + | _ -> + str (* Escape a string according to the OCaml lexing convention. *) let string_to_caml_string str = @@ -1291,6 +1315,7 @@ let format_of_aconv iconv c = (* Generate the format_float first argument form a float_conv. *) let format_of_fconv fconv prec = + let prec = abs prec in let symb = if fconv = Float_F then 'g' else char_of_fconv fconv in let buf = buffer_create 16 in buffer_add_char buf '%'; @@ -1309,6 +1334,7 @@ let convert_int64 iconv n = format_int64 (format_of_aconv iconv 'L') n (* Convert a float to string. *) (* Fix special case of "OCaml float format". *) let convert_float fconv prec x = + let prec = abs prec in let str = format_float (format_of_fconv fconv prec) x in if fconv <> Float_F then str else let len = String.length str in @@ -1414,6 +1440,10 @@ fun k o acc fmt -> match fmt with fun n -> let new_acc = Acc_data_string (acc, format_int "%u" n) in make_printf k o new_acc rest + | Scan_next_char rest -> + fun c -> + let new_acc = Acc_data_char (acc, c) in + make_printf k o new_acc rest | Ignored_param (ign, rest) -> make_ignored_param k o acc ign rest @@ -1453,6 +1483,7 @@ fun k o acc ign fmt -> match ign with | Ignored_reader -> assert false | Ignored_scan_char_set _ -> make_invalid_arg k o acc fmt | Ignored_scan_get_counter _ -> make_invalid_arg k o acc fmt + | Ignored_scan_next_char -> make_invalid_arg k o acc fmt (* Special case of printf "%_(". *) @@ -1789,26 +1820,39 @@ let fmt_ebb_of_string ?legacy_behavior str = in (* Raise a Failure with a friendly error message. *) + let invalid_format_message str_ind msg = + failwith_message + "invalid format %S: at character number %d, %s" + str str_ind msg; + in + (* Used when the end of the format (or the current sub-format) was encoutered unexpectedly. *) let unexpected_end_of_format end_ind = - failwith_message - "invalid format %S: at character number %d, unexpected end of format" - str end_ind; + invalid_format_message end_ind + "unexpected end of format" + in + (* Used for %0c: no other widths are implemented *) + let invalid_nonnull_char_width str_ind = + invalid_format_message str_ind + "non-zero widths are unsupported for %c conversions" + in (* Raise Failure with a friendly error message about an option dependencie problem. *) - and invalid_format_without str_ind c s = + let invalid_format_without str_ind c s = failwith_message "invalid format %S: at character number %d, '%c' without %s" str str_ind c s + in (* Raise Failure with a friendly error message about an unexpected character. *) - and expected_character str_ind expected read = + let expected_character str_ind expected read = failwith_message "invalid format %S: at character number %d, %s expected, read %C" - str str_ind expected read in + str str_ind expected read + in (* Parse the string from beg_ind (included) to end_ind (excluded). *) let rec parse : type e f . int -> int -> (_, _, e, f) fmt_ebb = @@ -1883,52 +1927,56 @@ let fmt_ebb_of_string ?legacy_behavior str = match str.[str_ind] with | '0' .. '9' -> let new_ind, width = parse_positive str_ind end_ind 0 in - parse_after_padding pct_ind new_ind end_ind plus sharp space ign + parse_after_padding pct_ind new_ind end_ind minus plus sharp space ign (Lit_padding (padty, width)) | '*' -> - parse_after_padding pct_ind (str_ind + 1) end_ind plus sharp space ign - (Arg_padding padty) + parse_after_padding pct_ind (str_ind + 1) end_ind minus plus sharp space + ign (Arg_padding padty) | _ -> - if legacy_behavior then - parse_after_padding pct_ind str_ind end_ind plus sharp space ign - No_padding - else begin match padty with + begin match padty with | Left -> - invalid_format_without (str_ind - 1) '-' "padding" + if not legacy_behavior then + invalid_format_without (str_ind - 1) '-' "padding"; + parse_after_padding pct_ind str_ind end_ind minus plus sharp space ign + No_padding | Zeros -> - invalid_format_without (str_ind - 1) '0' "padding" + (* a '0' padding indication not followed by anything should + be interpreted as a Right padding of width 0. This is used + by scanning conversions %0s and %0c *) + parse_after_padding pct_ind str_ind end_ind minus plus sharp space ign + (Lit_padding (Right, 0)) | Right -> - parse_after_padding pct_ind str_ind end_ind plus sharp space ign + parse_after_padding pct_ind str_ind end_ind minus plus sharp space ign No_padding end (* Is precision defined? *) and parse_after_padding : type x e f . - int -> int -> int -> bool -> bool -> bool -> bool -> (x, _) padding -> - (_, _, e, f) fmt_ebb = - fun pct_ind str_ind end_ind plus sharp space ign pad -> + int -> int -> int -> bool -> bool -> bool -> bool -> bool -> + (x, _) padding -> (_, _, e, f) fmt_ebb = + fun pct_ind str_ind end_ind minus plus sharp space ign pad -> if str_ind = end_ind then unexpected_end_of_format end_ind; match str.[str_ind] with | '.' -> - parse_precision pct_ind (str_ind + 1) end_ind plus sharp space ign pad + parse_precision pct_ind (str_ind + 1) end_ind minus plus sharp space ign + pad | symb -> parse_conversion pct_ind (str_ind + 1) end_ind plus sharp space ign pad - No_precision symb + No_precision pad symb (* Read the digital or '*' precision. *) and parse_precision : type x e f . - int -> int -> int -> bool -> bool -> bool -> bool -> (x, _) padding -> - (_, _, e, f) fmt_ebb = - fun pct_ind str_ind end_ind plus sharp space ign pad -> + int -> int -> int -> bool -> bool -> bool -> bool -> bool -> + (x, _) padding -> (_, _, e, f) fmt_ebb = + fun pct_ind str_ind end_ind minus plus sharp space ign pad -> if str_ind = end_ind then unexpected_end_of_format end_ind; - let parse_literal str_ind = + let parse_literal minus str_ind = let new_ind, prec = parse_positive str_ind end_ind 0 in - if new_ind = end_ind then unexpected_end_of_format end_ind; - parse_conversion pct_ind (new_ind + 1) end_ind plus sharp space ign pad - (Lit_precision prec) str.[new_ind] in + parse_after_precision pct_ind new_ind end_ind minus plus sharp space ign + pad (Lit_precision prec) in match str.[str_ind] with - | '0' .. '9' -> parse_literal str_ind - | ('+' | '-') when legacy_behavior -> + | '0' .. '9' -> parse_literal minus str_ind + | ('+' | '-') as symb when legacy_behavior -> (* Legacy mode would accept and ignore '+' or '-' before the integer describing the desired precision; not that this cannot happen for padding width, as '+' and '-' already have @@ -1937,47 +1985,67 @@ let fmt_ebb_of_string ?legacy_behavior str = That said, the idea (supported by this tweak) that width and precision literals are "integer literals" in the OCaml sense is still blatantly wrong, as 123_456 or 0xFF are rejected. *) - parse_literal (str_ind + 1) + parse_literal (minus || symb = '-') (str_ind + 1) | '*' -> - parse_after_precision pct_ind (str_ind + 1) end_ind plus sharp space ign - pad Arg_precision + parse_after_precision pct_ind (str_ind + 1) end_ind minus plus sharp space + ign pad Arg_precision | _ -> if legacy_behavior then (* note that legacy implementation did not ignore '.' without a number (as it does for padding indications), but interprets it as '.0' *) - parse_after_precision pct_ind str_ind end_ind plus sharp space ign pad (Lit_precision 0) else - invalid_format_without (str_ind - 1) '.' "precision" + parse_after_precision pct_ind str_ind end_ind minus plus sharp space ign + pad (Lit_precision 0) + else + invalid_format_without (str_ind - 1) '.' "precision" (* Try to read the conversion. *) - and parse_after_precision : type x z e f . - int -> int -> int -> bool -> bool -> bool -> bool -> (x, _) padding -> - (z, _) precision -> (_, _, e, f) fmt_ebb = - fun pct_ind str_ind end_ind plus sharp space ign pad prec -> + and parse_after_precision : type x y z t e f . + int -> int -> int -> bool -> bool -> bool -> bool -> bool -> + (x, y) padding -> (z, t) precision -> (_, _, e, f) fmt_ebb = + fun pct_ind str_ind end_ind minus plus sharp space ign pad prec -> if str_ind = end_ind then unexpected_end_of_format end_ind; - parse_conversion pct_ind (str_ind + 1) end_ind plus sharp space ign pad prec - str.[str_ind] + let parse_conv (type u) (type v) (padprec : (u, v) padding) = + parse_conversion pct_ind (str_ind + 1) end_ind plus sharp space ign pad + prec padprec str.[str_ind] in + (* in legacy mode, some formats (%s and %S) accept a weird mix of + padding and precision, which is merged as a single padding + information. For example, in %.10s the precision is implicitly + understood as padding %10s, but the left-padding component may + be specified either as a left padding or a negative precision: + %-.3s and %.-3s are equivalent to %-3s *) + match pad with + | No_padding -> ( + match minus, prec with + | _, No_precision -> parse_conv No_padding + | false, Lit_precision n -> parse_conv (Lit_padding (Right, n)) + | true, Lit_precision n -> parse_conv (Lit_padding (Left, n)) + | false, Arg_precision -> parse_conv (Arg_padding Right) + | true, Arg_precision -> parse_conv (Arg_padding Left) + ) + | pad -> parse_conv pad (* Case analysis on conversion. *) - and parse_conversion : type x y z t e f . + and parse_conversion : type x y z t u v e f . int -> int -> int -> bool -> bool -> bool -> bool -> (x, y) padding -> - (z, t) precision -> char -> (_, _, e, f) fmt_ebb = - fun pct_ind str_ind end_ind plus sharp space ign pad prec symb -> + (z, t) precision -> (u, v) padding -> char -> (_, _, e, f) fmt_ebb = + fun pct_ind str_ind end_ind plus sharp space ign pad prec padprec symb -> (* Flags used to check option usages/compatibilities. *) let plus_used = ref false and sharp_used = ref false and space_used = ref false and ign_used = ref false and pad_used = ref false and prec_used = ref false in (* Access to options, update flags. *) - let get_plus () = plus_used := true; plus - and get_sharp () = sharp_used := true; sharp - and get_space () = space_used := true; space - and get_ign () = ign_used := true; ign - and get_pad () = pad_used := true; pad - and get_prec () = prec_used := true; prec in + let get_plus () = plus_used := true; plus + and get_sharp () = sharp_used := true; sharp + and get_space () = space_used := true; space + and get_ign () = ign_used := true; ign + and get_pad () = pad_used := true; pad + and get_prec () = prec_used := true; prec + and get_padprec () = pad_used := true; padprec in (* Check that padty <> Zeros. *) - let check_no_0 symb (type a) (type b) (pad : (a,b) padding) = + let check_no_0 symb (type a) (type b) (pad : (a, b) padding) = match pad with | No_padding -> pad | Lit_padding ((Left | Right), _) -> pad @@ -1993,7 +2061,7 @@ let fmt_ebb_of_string ?legacy_behavior str = (* Get padding as a pad_option (see "%_", "%{", "%(" and "%["). (no need for legacy mode tweaking, those were rejected by the legacy parser as well) *) - let get_pad_opt c = match get_pad () with + let opt_of_pad c (type a) (type b) (pad : (a, b) padding) = match pad with | No_padding -> None | Lit_padding (Right, width) -> Some width | Lit_padding (Zeros, width) -> @@ -2002,8 +2070,10 @@ let fmt_ebb_of_string ?legacy_behavior str = | Lit_padding (Left, width) -> if legacy_behavior then Some width else incompatible_flag pct_ind str_ind c "'-'" - | Arg_padding _ -> incompatible_flag pct_ind str_ind c "'*'" + | Arg_padding _ -> incompatible_flag pct_ind str_ind c "'*'" in + let get_pad_opt c = opt_of_pad c (get_pad ()) in + let get_padprec_opt c = opt_of_pad c (get_padprec ()) in (* Get precision as a prec_option (see "%_f"). (no need for legacy mode tweaking, those were rejected by the @@ -2018,28 +2088,44 @@ let fmt_ebb_of_string ?legacy_behavior str = | ',' -> parse str_ind end_ind | 'c' -> + let char_format fmt_rest = (* %c *) + if get_ign () + then Fmt_EBB (Ignored_param (Ignored_char, fmt_rest)) + else Fmt_EBB (Char fmt_rest) + in + let scan_format fmt_rest = (* %0c *) + if get_ign () + then Fmt_EBB (Ignored_param (Ignored_scan_next_char, fmt_rest)) + else Fmt_EBB (Scan_next_char fmt_rest) + in let Fmt_EBB fmt_rest = parse str_ind end_ind in - if get_ign () then Fmt_EBB (Ignored_param (Ignored_char, fmt_rest)) - else Fmt_EBB (Char fmt_rest) + begin match get_pad_opt 'c' with + | None -> char_format fmt_rest + | Some 0 -> scan_format fmt_rest + | Some _n -> + if not legacy_behavior + then invalid_nonnull_char_width str_ind + else (* legacy ignores %c widths *) char_format fmt_rest + end | 'C' -> let Fmt_EBB fmt_rest = parse str_ind end_ind in if get_ign () then Fmt_EBB (Ignored_param (Ignored_caml_char,fmt_rest)) else Fmt_EBB (Caml_char fmt_rest) | 's' -> - let pad = check_no_0 symb (get_pad ()) in + let pad = check_no_0 symb (get_padprec ()) in let Fmt_EBB fmt_rest = parse str_ind end_ind in if get_ign () then - let ignored = Ignored_string (get_pad_opt '_') in + let ignored = Ignored_string (get_padprec_opt '_') in Fmt_EBB (Ignored_param (ignored, fmt_rest)) else let Padding_fmt_EBB (pad', fmt_rest') = make_padding_fmt_ebb pad fmt_rest in Fmt_EBB (String (pad', fmt_rest')) | 'S' -> - let pad = check_no_0 symb (get_pad ()) in + let pad = check_no_0 symb (get_padprec ()) in let Fmt_EBB fmt_rest = parse str_ind end_ind in if get_ign () then - let ignored = Ignored_caml_string (get_pad_opt '_') in + let ignored = Ignored_caml_string (get_padprec_opt '_') in Fmt_EBB (Ignored_param (ignored, fmt_rest)) else let Padding_fmt_EBB (pad', fmt_rest') = @@ -2053,8 +2139,31 @@ let fmt_ebb_of_string ?legacy_behavior str = let ignored = Ignored_int (iconv, get_pad_opt '_') in Fmt_EBB (Ignored_param (ignored, fmt_rest)) else + (* %5.3d is accepted and meaningful: pad to length 5 with + spaces, but first pad with zeros upto length 3 (0-padding + is the interpretation of "precision" for integer formats). + + %05.3d is redundant: pad to length 5 *with zeros*, but + first pad with zeros... To add insult to the injury, the + legacy implementation ignores the 0-padding indication and + does the 5 padding with spaces instead. We reuse this + interpretation for compatiblity, but statically reject this + format when the legacy mode is disabled, to protect strict + users from this corner case. + *) + let pad = match get_pad (), get_prec () with + | pad, No_precision -> pad + | No_padding, _ -> No_padding + | Lit_padding (Zeros, n), _ -> + if legacy_behavior then Lit_padding (Right, n) + else incompatible_flag pct_ind str_ind '0' "precision" + | Arg_padding Zeros, _ -> + if legacy_behavior then Arg_padding Right + else incompatible_flag pct_ind str_ind '0' "precision" + | Lit_padding _ as pad, _ -> pad + | Arg_padding _ as pad, _ -> pad in let Padprec_fmt_EBB (pad', prec', fmt_rest') = - make_padprec_fmt_ebb (get_pad ()) (get_prec ()) fmt_rest in + make_padprec_fmt_ebb pad (get_prec ()) fmt_rest in Fmt_EBB (Int (iconv, pad', prec', fmt_rest')) | 'N' -> let Fmt_EBB fmt_rest = parse str_ind end_ind in @@ -2294,7 +2403,7 @@ let fmt_ebb_of_string ?legacy_behavior str = fun str_ind end_ind -> let next_ind, formatting_lit = try - if str_ind = end_ind || str.[str_ind] <> '<' then raise Not_found; + if str_ind = end_ind || str.[str_ind] <> '<' then raise Not_found; let str_ind_1 = parse_spaces (str_ind + 1) end_ind in match str.[str_ind_1] with | '0' .. '9' | '-' -> ( @@ -2542,24 +2651,24 @@ let fmt_ebb_of_string ?legacy_behavior str = | _, true, _, 'x' when legacy_behavior -> Int_Cx | _, true, _, 'X' when legacy_behavior -> Int_CX | _, true, _, 'o' when legacy_behavior -> Int_Co - | _, true, _, _ -> + | _, true, _, ('d' | 'i' | 'u') -> if legacy_behavior then (* ignore *) compute_int_conv pct_ind str_ind plus false space symb else incompatible_flag pct_ind str_ind symb "'#'" - | true, false, true, _ -> + | true, _, true, _ -> if legacy_behavior then (* plus and space: legacy implementation prefers plus *) compute_int_conv pct_ind str_ind plus sharp false symb else incompatible_flag pct_ind str_ind ' ' "'+'" - | false, false, true, _ -> + | false, _, true, _ -> if legacy_behavior then (* ignore *) compute_int_conv pct_ind str_ind plus sharp false symb else incompatible_flag pct_ind str_ind symb "' '" - | true, false, false, _ -> + | true, _, false, _ -> if legacy_behavior then (* ignore *) compute_int_conv pct_ind str_ind false sharp space symb else incompatible_flag pct_ind str_ind symb "'+'" - | false, false, false, _ -> assert false + | false, _, false, _ -> assert false (* Convert (plus, symb) to its associated float_conv. *) and compute_float_conv pct_ind str_ind plus space symb = diff --git a/stdlib/camlinternalFormatBasics.ml b/stdlib/camlinternalFormatBasics.ml index e51e4e2c..f45f434c 100644 --- a/stdlib/camlinternalFormatBasics.ml +++ b/stdlib/camlinternalFormatBasics.ml @@ -410,6 +410,9 @@ and ('a, 'b, 'c, 'd, 'e, 'f) fmt = | Scan_get_counter : (* %[nlNL] *) counter * ('a, 'b, 'c, 'd, 'e, 'f) fmt -> (int -> 'a, 'b, 'c, 'd, 'e, 'f) fmt + | Scan_next_char : (* %0c *) + ('a, 'b, 'c, 'd, 'e, 'f) fmt -> + (char -> 'a, 'b, 'c, 'd, 'e, 'f) fmt | Ignored_param : (* %_ *) ('a, 'b, 'c, 'd, 'y, 'x) ignored * ('x, 'b, 'c, 'y, 'e, 'f) fmt -> ('a, 'b, 'c, 'd, 'e, 'f) fmt @@ -453,6 +456,8 @@ and ('a, 'b, 'c, 'd, 'e, 'f) ignored = pad_option * char_set -> ('a, 'b, 'c, 'd, 'd, 'a) ignored | Ignored_scan_get_counter : (* %_[nlNL] *) counter -> ('a, 'b, 'c, 'd, 'd, 'a) ignored + | Ignored_scan_next_char : (* %_0c *) + ('a, 'b, 'c, 'd, 'd, 'a) ignored and ('a, 'b, 'c, 'd, 'e, 'f) format6 = Format of ('a, 'b, 'c, 'd, 'e, 'f) fmt * string @@ -602,6 +607,8 @@ fun fmt1 fmt2 -> match fmt1 with Scan_char_set (width_opt, char_set, concat_fmt rest fmt2) | Scan_get_counter (counter, rest) -> Scan_get_counter (counter, concat_fmt rest fmt2) + | Scan_next_char (rest) -> + Scan_next_char (concat_fmt rest fmt2) | Ignored_param (ign, rest) -> Ignored_param (ign, concat_fmt rest fmt2) diff --git a/stdlib/camlinternalFormatBasics.mli b/stdlib/camlinternalFormatBasics.mli index 52f428ad..4e579f3a 100644 --- a/stdlib/camlinternalFormatBasics.mli +++ b/stdlib/camlinternalFormatBasics.mli @@ -225,6 +225,11 @@ and ('a, 'b, 'c, 'd, 'e, 'f) fmt = | Scan_get_counter : (* %[nlNL] *) counter * ('a, 'b, 'c, 'd, 'e, 'f) fmt -> (int -> 'a, 'b, 'c, 'd, 'e, 'f) fmt +| Scan_next_char : (* %0c *) + ('a, 'b, 'c, 'd, 'e, 'f) fmt -> + (char -> 'a, 'b, 'c, 'd, 'e, 'f) fmt + (* %0c behaves as %c for printing, but when scanning it does not + consume the character from the input stream *) | Ignored_param : (* %_ *) ('a, 'b, 'c, 'd, 'y, 'x) ignored * ('x, 'b, 'c, 'y, 'e, 'f) fmt -> ('a, 'b, 'c, 'd, 'e, 'f) fmt @@ -265,6 +270,8 @@ and ('a, 'b, 'c, 'd, 'e, 'f) ignored = pad_option * char_set -> ('a, 'b, 'c, 'd, 'd, 'a) ignored | Ignored_scan_get_counter : counter -> ('a, 'b, 'c, 'd, 'd, 'a) ignored + | Ignored_scan_next_char : + ('a, 'b, 'c, 'd, 'd, 'a) ignored and ('a, 'b, 'c, 'd, 'e, 'f) format6 = Format of ('a, 'b, 'c, 'd, 'e, 'f) fmt * string diff --git a/stdlib/camlinternalMod.ml b/stdlib/camlinternalMod.ml index 5f1882a2..5265a712 100644 --- a/stdlib/camlinternalMod.ml +++ b/stdlib/camlinternalMod.ml @@ -67,5 +67,4 @@ let rec update_mod shape o n = for i = 0 to Array.length comps - 1 do update_mod comps.(i) (Obj.field o i) (Obj.field n i) done - | Value v -> - overwrite o n + | Value v -> () (* the value is already there *) diff --git a/stdlib/filename.mli b/stdlib/filename.mli index a4ea3aaa..c2cc6a48 100644 --- a/stdlib/filename.mli +++ b/stdlib/filename.mli @@ -117,7 +117,8 @@ val set_temp_dir_name : string -> unit @since 4.00.0 *) -val temp_dir_name : string [@@ocaml.deprecated] +val temp_dir_name : string + [@@ocaml.deprecated "Use Filename.get_temp_dir_name instead"] (** The name of the initial temporary directory: Under Unix, the value of the [TMPDIR] environment variable, or "/tmp" if the variable is not set. diff --git a/stdlib/format.mli b/stdlib/format.mli index b44fc0a9..541ffbe3 100644 --- a/stdlib/format.mli +++ b/stdlib/format.mli @@ -724,7 +724,7 @@ val bprintf : Buffer.t -> ('a, formatter, unit) format -> 'a use regular calls to [Format.fprintf] on formatter [to_b]. *) val kprintf : (string -> 'a) -> ('b, unit, string, 'a) format4 -> 'b - [@@ocaml.deprecated] + [@@ocaml.deprecated "Use Format.ksprintf instead."] ;; (** @deprecated An alias for [ksprintf]. *) @@ -734,7 +734,7 @@ val set_all_formatter_output_functions : newline:(unit -> unit) -> spaces:(int -> unit) -> unit -[@@ocaml.deprecated] +[@@ocaml.deprecated "Use Format.set_formatter_out_functions instead."] ;; (** @deprecated Subsumed by [set_formatter_out_functions]. *) @@ -745,14 +745,14 @@ val get_all_formatter_output_functions : (unit -> unit) * (unit -> unit) * (int -> unit) -[@@ocaml.deprecated] +[@@ocaml.deprecated "Use Format.get_formatter_out_functions instead."] ;; (** @deprecated Subsumed by [get_formatter_out_functions]. *) val pp_set_all_formatter_output_functions : formatter -> out:(string -> int -> int -> unit) -> flush:(unit -> unit) -> newline:(unit -> unit) -> spaces:(int -> unit) -> unit -[@@ocaml.deprecated] +[@@ocaml.deprecated "Use Format.pp_set_formatter_out_functions instead."] ;; (** @deprecated Subsumed by [pp_set_formatter_out_functions]. *) @@ -761,7 +761,7 @@ val pp_get_all_formatter_output_functions : formatter -> unit -> (string -> int -> int -> unit) * (unit -> unit) * (unit -> unit) * (int -> unit) -[@@ocaml.deprecated] +[@@ocaml.deprecated "Use Format.pp_get_formatter_out_functions instead."] ;; (** @deprecated Subsumed by [pp_get_formatter_out_functions]. *) diff --git a/stdlib/gc.mli b/stdlib/gc.mli index 8cd2a719..f86a1e68 100644 --- a/stdlib/gc.mli +++ b/stdlib/gc.mli @@ -83,7 +83,7 @@ type stat = type control = { mutable minor_heap_size : int; (** The size (in words) of the minor heap. Changing - this parameter will trigger a minor collection. Default: 32k. *) + this parameter will trigger a minor collection. Default: 256k. *) mutable major_heap_increment : int; (** How much to add to the major heap when increasing it. If this @@ -131,7 +131,7 @@ type control = mutable stack_limit : int; (** The maximum size of the stack (in words). This is only relevant to the byte-code runtime, as the native code runtime - uses the operating system's stack. Default: 256k. *) + uses the operating system's stack. Default: 1024k. *) mutable allocation_policy : int; (** The policy used for allocating in the heap. Possible diff --git a/stdlib/lazy.mli b/stdlib/lazy.mli index 6ade2e3d..f2541b7f 100644 --- a/stdlib/lazy.mli +++ b/stdlib/lazy.mli @@ -75,11 +75,14 @@ val is_val : 'a t -> bool;; did not raise an exception. @since 4.00.0 *) -val lazy_from_fun : (unit -> 'a) -> 'a t [@@ocaml.deprecated];; +val lazy_from_fun : (unit -> 'a) -> 'a t + [@@ocaml.deprecated "Use Lazy.from_fun instead."];; (** @deprecated synonym for [from_fun]. *) -val lazy_from_val : 'a -> 'a t [@@ocaml.deprecated];; +val lazy_from_val : 'a -> 'a t + [@@ocaml.deprecated "Use Lazy.from_val instead."];; (** @deprecated synonym for [from_val]. *) -val lazy_is_val : 'a t -> bool [@@ocaml.deprecated];; +val lazy_is_val : 'a t -> bool + [@@ocaml.deprecated "Use Lazy.is_val instead."];; (** @deprecated synonym for [is_val]. *) diff --git a/stdlib/obj.mli b/stdlib/obj.mli index 08b8a4f6..3395fa86 100644 --- a/stdlib/obj.mli +++ b/stdlib/obj.mli @@ -47,7 +47,8 @@ val string_tag : int (* both [string] and [bytes] *) val double_tag : int val double_array_tag : int val custom_tag : int -val final_tag : int [@@ocaml.deprecated] +val final_tag : int + [@@ocaml.deprecated "Replaced by custom_tag."] val int_tag : int val out_of_heap_tag : int @@ -60,5 +61,7 @@ val extension_slot : 'a -> t (** The following two functions are deprecated. Use module {!Marshal} instead. *) -val marshal : t -> bytes [@@ocaml.deprecated] -val unmarshal : bytes -> int -> t * int [@@ocaml.deprecated] +val marshal : t -> bytes + [@@ocaml.deprecated "Use Marshal.to_bytes instead."] +val unmarshal : bytes -> int -> t * int + [@@ocaml.deprecated "Use Marshal.from_bytes and Marshal.total_size instead."] diff --git a/stdlib/pervasives.mli b/stdlib/pervasives.mli index d471a4eb..64138291 100644 --- a/stdlib/pervasives.mli +++ b/stdlib/pervasives.mli @@ -130,7 +130,7 @@ external ( && ) : bool -> bool -> bool = "%sequand" [e2] is not evaluated at all. *) external ( & ) : bool -> bool -> bool = "%sequand" - [@@ocaml.deprecated] + [@@ocaml.deprecated "Use (&&) instead."] (** @deprecated {!Pervasives.( && )} should be used instead. *) external ( || ) : bool -> bool -> bool = "%sequor" @@ -139,7 +139,7 @@ external ( || ) : bool -> bool -> bool = "%sequor" [e2] is not evaluated at all. *) external ( or ) : bool -> bool -> bool = "%sequor" - [@@ocaml.deprecated] + [@@ocaml.deprecated "Use (||) instead."] (** @deprecated {!Pervasives.( || )} should be used instead.*) (** {6 Debugging} *) diff --git a/stdlib/printf.mli b/stdlib/printf.mli index 21e28159..4a725665 100644 --- a/stdlib/printf.mli +++ b/stdlib/printf.mli @@ -92,7 +92,9 @@ val fprintf : out_channel -> ('a, out_channel, unit) format -> 'a sign if positive. - space: for signed numerical conversions, prefix number with a space if positive. - - [#]: request an alternate formatting style for numbers. + - [#]: request an alternate formatting style for the hexadecimal + and octal integer types ([x], [X], [o], [lx], [lX], [lo], [Lx], + [LX], [Lo]). The optional [width] is an integer indicating the minimal width of the result. For instance, [%6d] prints an integer, diff --git a/stdlib/scanf.ml b/stdlib/scanf.ml index 2a63ced9..1372c41a 100644 --- a/stdlib/scanf.ml +++ b/stdlib/scanf.ml @@ -1032,6 +1032,7 @@ fun k fmt -> match fmt with | Scan_char_set (_, _, rest) -> take_format_readers k rest | Scan_get_counter (_, rest) -> take_format_readers k rest + | Scan_next_char rest -> take_format_readers k rest | Formatting_lit (_, rest) -> take_format_readers k rest | Formatting_gen (Open_tag (Format (fmt, _)), rest) -> take_format_readers k (concat_fmt fmt rest) @@ -1096,6 +1097,7 @@ fun k ign fmt -> match ign with | Ignored_format_subst (_, fmtty) -> take_fmtty_format_readers k fmtty fmt | Ignored_scan_char_set _ -> take_format_readers k fmt | Ignored_scan_get_counter _ -> take_format_readers k fmt + | Ignored_scan_next_char -> take_format_readers k fmt (******************************************************************************) (* Generic scanning *) @@ -1225,6 +1227,9 @@ fun ib fmt readers -> match fmt with | Scan_get_counter (counter, rest) -> let count = get_counter ib counter in Cons (count, make_scanf ib rest readers) + | Scan_next_char rest -> + let c = Scanning.checked_peek_char ib in + Cons (c, make_scanf ib rest readers) | Formatting_lit (formatting_lit, rest) -> String.iter (check_char ib) (string_of_formatting_lit formatting_lit); diff --git a/stdlib/sort.mli b/stdlib/sort.mli index a9be27e1..2da46cd7 100644 --- a/stdlib/sort.mli +++ b/stdlib/sort.mli @@ -20,13 +20,13 @@ *) val list : ('a -> 'a -> bool) -> 'a list -> 'a list - [@@ocaml.deprecated] + [@@ocaml.deprecated "Use List.sort instead."] (** Sort a list in increasing order according to an ordering predicate. The predicate should return [true] if its first argument is less than or equal to its second argument. *) val array : ('a -> 'a -> bool) -> 'a array -> unit - [@@ocaml.deprecated] + [@@ocaml.deprecated "Use Array.sort instead."] (** Sort an array in increasing order according to an ordering predicate. The predicate should return [true] if its first argument is @@ -34,7 +34,7 @@ val array : ('a -> 'a -> bool) -> 'a array -> unit The array is sorted in place. *) val merge : ('a -> 'a -> bool) -> 'a list -> 'a list -> 'a list - [@@ocaml.deprecated] + [@@ocaml.deprecated "Use List.merge instead."] (** Merge two lists according to the given predicate. Assuming the two argument lists are sorted according to the predicate, [merge] returns a sorted list containing the elements diff --git a/stdlib/string.mli b/stdlib/string.mli index 8f1e178b..56065bbf 100644 --- a/stdlib/string.mli +++ b/stdlib/string.mli @@ -57,7 +57,7 @@ external get : string -> int -> char = "%string_safe_get" external set : bytes -> int -> char -> unit = "%string_safe_set" - [@@ocaml.deprecated] + [@@ocaml.deprecated "Use Bytes.set instead."] (** [String.set s n c] modifies byte sequence [s] in place, replacing the byte at index [n] with [c]. You can also write [s.[n] <- c] instead of [String.set s n c]. @@ -66,7 +66,8 @@ external set : bytes -> int -> char -> unit = "%string_safe_set" @deprecated This is a deprecated alias of {!Bytes.set}.[ ] *) -external create : int -> bytes = "caml_create_string" [@@ocaml.deprecated] +external create : int -> bytes = "caml_create_string" + [@@ocaml.deprecated "Use Bytes.create instead."] (** [String.create n] returns a fresh byte sequence of length [n]. The sequence is uninitialized and contains arbitrary bytes. @@ -104,7 +105,8 @@ val sub : string -> int -> int -> string Raise [Invalid_argument] if [start] and [len] do not designate a valid substring of [s]. *) -val fill : bytes -> int -> int -> char -> unit [@@ocaml.deprecated] +val fill : bytes -> int -> int -> char -> unit + [@@ocaml.deprecated "Use Bytes.fill instead."] (** [String.fill s start len c] modifies byte sequence [s] in place, replacing [len] bytes with [c], starting at [start]. diff --git a/stdlib/stringLabels.mli b/stdlib/stringLabels.mli index 1cf5d51e..6f6f997e 100644 --- a/stdlib/stringLabels.mli +++ b/stdlib/stringLabels.mli @@ -23,22 +23,23 @@ external get : string -> int -> char = "%string_safe_get" Raise [Invalid_argument] if [n] not a valid index in [s]. *) external set : bytes -> int -> char -> unit = "%string_safe_set" - [@@ocaml.deprecated] + [@@ocaml.deprecated "Use BytesLabels.set instead."] (** [String.set s n c] modifies byte sequence [s] in place, replacing the byte at index [n] with [c]. You can also write [s.[n] <- c] instead of [String.set s n c]. Raise [Invalid_argument] if [n] is not a valid index in [s]. - @deprecated This is a deprecated alias of {!Bytes.set}. *) + @deprecated This is a deprecated alias of {!BytesLabels.set}. *) -external create : int -> bytes = "caml_create_string" [@@ocaml.deprecated] +external create : int -> bytes = "caml_create_string" + [@@ocaml.deprecated "Use BytesLabels.create instead."] (** [String.create n] returns a fresh byte sequence of length [n]. The sequence is uninitialized and contains arbitrary bytes. Raise [Invalid_argument] if [n < 0] or [n > ]{!Sys.max_string_length}. - @deprecated This is a deprecated alias of {!Bytes.create}. *) + @deprecated This is a deprecated alias of {!BytesLabels.create}. *) val make : int -> char -> string (** [String.make n c] returns a fresh string of length [n], @@ -63,14 +64,15 @@ val sub : string -> pos:int -> len:int -> string Raise [Invalid_argument] if [start] and [len] do not designate a valid substring of [s]. *) -val fill : bytes -> pos:int -> len:int -> char -> unit [@@ocaml.deprecated] +val fill : bytes -> pos:int -> len:int -> char -> unit + [@@ocaml.deprecated "Use BytesLabels.fill instead."] (** [String.fill s start len c] modifies byte sequence [s] in place, replacing [len] bytes by [c], starting at [start]. Raise [Invalid_argument] if [start] and [len] do not designate a valid substring of [s]. - @deprecated This is a deprecated alias of {!Bytes.fill}. *) + @deprecated This is a deprecated alias of {!BytesLabels.fill}. *) val blit : src:string -> src_pos:int -> dst:bytes -> dst_pos:int -> len:int diff --git a/testsuite/tests/backtrace/Makefile b/testsuite/tests/backtrace/Makefile index 1ca390f9..33ca1ed8 100644 --- a/testsuite/tests/backtrace/Makefile +++ b/testsuite/tests/backtrace/Makefile @@ -16,6 +16,7 @@ EXECNAME=program$(EXE) ABCDFILES=backtrace.ml OTHERFILES=backtrace2.ml raw_backtrace.ml \ backtrace_deprecated.ml backtrace_slots.ml +OTHERFILESNOINLINING=backtraces_and_finalizers.ml default: $(MAKE) byte @@ -69,6 +70,16 @@ native: >$$F.native.result 2>&1; \ $(DIFF) $$F.reference $$F.native.result >/dev/null \ && echo " => passed" || echo " => failed"; \ + done; + @for file in $(OTHERFILESNOINLINING); do \ + rm -f program program.exe; \ + $(OCAMLOPT) -inline 0 -g -o $(EXECNAME) $$file; \ + printf " ... testing '$$file' with ocamlopt:"; \ + F="`basename $$file .ml`"; \ + (OCAMLRUNPARAM=b=1 ./$(EXECNAME) $$arg || true) \ + >$$F.native.result 2>&1; \ + $(DIFF) $$F.reference $$F.native.result >/dev/null \ + && echo " => passed" || echo " => failed"; \ done .PHONY: promote diff --git a/testsuite/tests/backtrace/backtraces_and_finalizers.ml b/testsuite/tests/backtrace/backtraces_and_finalizers.ml new file mode 100644 index 00000000..22acf1af --- /dev/null +++ b/testsuite/tests/backtrace/backtraces_and_finalizers.ml @@ -0,0 +1,25 @@ +let () = Printexc.record_backtrace true + +let finaliser _ = try raise Exit with _ -> () + +let create () = + let x = ref () in + Gc.finalise finaliser x; + x + +let f () = raise Exit + +let () = + let minor_size = (Gc.get ()).Gc.minor_heap_size in + for i = 1 to 100 do + Gc.minor (); + try + ignore (create () : unit ref); + f () + with _ -> + for i = 1 to minor_size / 2 - 1 do + ignore (ref ()) + done; + ignore (Printexc.get_backtrace () : string) + done; + Printf.printf "ok\n" diff --git a/testsuite/tests/backtrace/backtraces_and_finalizers.reference b/testsuite/tests/backtrace/backtraces_and_finalizers.reference new file mode 100644 index 00000000..9766475a --- /dev/null +++ b/testsuite/tests/backtrace/backtraces_and_finalizers.reference @@ -0,0 +1 @@ +ok diff --git a/testsuite/tests/formats-transition/invalid_formats.ml b/testsuite/tests/formats-transition/invalid_formats.ml new file mode 100644 index 00000000..16697ca9 --- /dev/null +++ b/testsuite/tests/formats-transition/invalid_formats.ml @@ -0,0 +1,67 @@ +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Damien Doligez, EPI Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2014 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* WARNING: this file MUST NOT be merged into the trunk, it is for the + 4.02 branch only, to test compatibility with the old implementation + of printf. Starting with 4.03, all these formats will be statically + refused by the compiler. +*) + +open Printf;; + +let show arg f = + printf "%8s --> |" (string_of_format f); + printf f arg; + printf "|\n"; +in + + List.iter (show 12.3) [ + "%0.3f"; + "%0.f"; + "%+ .3f"; + "%.f"; + "%3.f"; + "%-9.f"; + "%0.16g"; + ]; + + List.iter (show "ab") [ + "%.30s"; + "%-.30s"; + "%-s"; + "%0s"; + "%03s"; + "% s"; + ]; + + List.iter (show 4) [ + "%0.3d"; + "%0X"; + "%0x"; + ]; + + List.iter (show 'a') [ + "%5c"; + ]; +;; + +let fmt = format_of_string "%0.*f" in +printf "%8s --> |" (string_of_format fmt); +printf fmt 3 12.3; +printf "|\n"; +;; + +let fmt = format_of_string "%.2%" in +printf "%8s --> |" (string_of_format fmt); +printf fmt; +printf "|\n"; +;; diff --git a/testsuite/tests/formats-transition/invalid_formats.ml.reference b/testsuite/tests/formats-transition/invalid_formats.ml.reference new file mode 100644 index 00000000..65881b42 --- /dev/null +++ b/testsuite/tests/formats-transition/invalid_formats.ml.reference @@ -0,0 +1,24 @@ + +# * * * * # %0.3f --> |12.300| + %0.f --> |12| + %+ .3f --> |+12.300| + %.f --> |12| + %3.f --> | 12| + %-9.f --> |12 | + %0.16g --> |12.3| + %.30s --> | ab| + %-.30s --> |ab | + %-s --> |ab| + %0s --> |ab| + %03s --> | ab| + % s --> |ab| + %0.3d --> |004| + %0X --> |4| + %0x --> |4| + %5c --> |a| +- : unit = () +# %0.*f --> |12.300| +- : unit = () +# %.2% --> |%| +- : unit = () +# diff --git a/testsuite/tests/lib-dynlink-native/Makefile b/testsuite/tests/lib-dynlink-native/Makefile index 54126ff5..f4f9d099 100644 --- a/testsuite/tests/lib-dynlink-native/Makefile +++ b/testsuite/tests/lib-dynlink-native/Makefile @@ -49,7 +49,7 @@ run: main$(EXE): api.cmx main.cmx @$(OCAMLOPT) -thread -o main$(EXE) -linkall unix.cmxa threads.cmxa \ - dynlink.cmxa api.cmx main.cmx $(PTHREAD_LINK) + dynlink.cmxa api.cmx main.cmx main_ext$(EXE): api.cmx main.cmx factorial.$(O) @$(OCAMLOPT) -o main_ext$(EXE) dynlink.cmxa api.cmx main.cmx \ diff --git a/testsuite/tests/lib-format/Makefile b/testsuite/tests/lib-format/Makefile index 7a6297b6..9805d2db 100644 --- a/testsuite/tests/lib-format/Makefile +++ b/testsuite/tests/lib-format/Makefile @@ -10,11 +10,8 @@ # # ######################################################################### -MAIN_MODULE=tformat -ADD_COMPFLAGS=-I $(OTOPDIR)/testsuite/lib -ADD_MODULES=testing - BASEDIR=../.. +MODULES=testing -include $(BASEDIR)/makefiles/Makefile.one +include $(BASEDIR)/makefiles/Makefile.several include $(BASEDIR)/makefiles/Makefile.common diff --git a/testsuite/tests/lib-format/tformat.ml b/testsuite/tests/lib-format/tformat.ml index a627b47f..13c6094b 100644 --- a/testsuite/tests/lib-format/tformat.ml +++ b/testsuite/tests/lib-format/tformat.ml @@ -31,6 +31,7 @@ try test (sprintf "% d/% i" 42 43 = " 42/ 43"); test (sprintf "%#d/%#i" 42 43 = "42/43"); test (sprintf "%4d/%5i" 42 43 = " 42/ 43"); + test (sprintf "%*d" (-4) 42 = "42 "); test (sprintf "%*d/%*i" 4 42 5 43 = " 42/ 43"); test (sprintf "%-0+#4d/%-0 #5i" 42 43 = "+42 / 43 "); @@ -42,6 +43,7 @@ try test (sprintf "% d/% i" (-42) (-43) = "-42/-43"); test (sprintf "%#d/%#i" (-42) (-43) = "-42/-43"); test (sprintf "%4d/%5i" (-42) (-43) = " -42/ -43"); + test (sprintf "%*d" (-4) (-42) = "-42 "); test (sprintf "%*d/%*i" 4 (-42) 5 (-43) = " -42/ -43"); test (sprintf "%-0+ #4d/%-0+ #5i" (-42) (-43) = "-42 /-43 "); @@ -54,7 +56,7 @@ try test (sprintf "%#u" 42 = "42"); test (sprintf "%4u" 42 = " 42"); test (sprintf "%*u" 4 42 = " 42"); - test (sprintf "%-0+ #6d" 42 = "+42 "); + test (sprintf "%*u" (-4) 42 = "42 "); say "\nu negative\n%!"; begin match Sys.word_size with @@ -74,6 +76,10 @@ try test (sprintf "%#x" 42 = "0x2a"); test (sprintf "%4x" 42 = " 2a"); test (sprintf "%*x" 5 42 = " 2a"); + test (sprintf "%*x" (-5) 42 = "2a "); + test (sprintf "%#*x" 5 42 = " 0x2a"); + test (sprintf "%#*x" (-5) 42 = "0x2a "); + test (sprintf "%#-*x" 5 42 = "0x2a "); test (sprintf "%-0+ #*x" 5 42 = "0x2a "); say "\nx negative\n%!"; @@ -135,6 +141,7 @@ try test (sprintf "%5s" "foo" = " foo"); test (sprintf "%1s" "foo" = "foo"); test (sprintf "%*s" 6 "foo" = " foo"); + test (sprintf "%*s" (-6) "foo" = "foo "); test (sprintf "%*s" 2 "foo" = "foo"); test (sprintf "%-0+ #5s" "foo" = "foo "); test (sprintf "%s@@" "foo" = "foo@"); @@ -143,16 +150,19 @@ try say "\nS\n%!"; test (sprintf "%S" "fo\"o" = "\"fo\\\"o\""); -(* test (sprintf "%-5S" "foo" = "\"foo\" "); padding not done *) -(* test (sprintf "%05S" "foo" = " \"foo\""); padding not done *) + test (sprintf "%-7S" "foo" = "\"foo\" "); +(* test (sprintf "%07S" "foo" = " \"foo\""); *) + (* %S is incompatible with '0' *) test (sprintf "%+S" "foo" = "\"foo\""); test (sprintf "% S" "foo" = "\"foo\""); test (sprintf "%#S" "foo" = "\"foo\""); -(* test (sprintf "%5S" "foo" = " \"foo\""); padding not done *) + test (sprintf "%7S" "foo" = " \"foo\""); test (sprintf "%1S" "foo" = "\"foo\""); -(* test (sprintf "%*S" 6 "foo" = " \"foo\""); padding not done *) + test (sprintf "%*S" 8 "foo" = " \"foo\""); + test (sprintf "%*S" (-8) "foo" = "\"foo\" "); test (sprintf "%*S" 2 "foo" = "\"foo\""); (* test (sprintf "%-0+ #5S" "foo" = "\"foo\" "); padding not done *) + (* %S is incompatible with '0','+' and ' ' *) test (sprintf "%S@@" "foo" = "\"foo\"@"); test (sprintf "%S@@inria.fr" "foo" = "\"foo\"@inria.fr"); test (sprintf "%S@@%S" "foo" "inria.fr" = "\"foo\"@\"inria.fr\""); @@ -229,7 +239,13 @@ try test (sprintf "%F" 42.42e42 =* "4.242e+43"); test (sprintf "%F" 42.00 = "42."); test (sprintf "%F" 0.042 = "0.042"); -(* no padding, no precision + test (sprintf "%4F" 3. = " 3."); + test (sprintf "%-4F" 3. = "3. "); + test (sprintf "%04F" 3. = "003."); +(* plus-padding unsupported + test (sprintf "%+4F" 3. = " +3."); +*) +(* no precision test (sprintf "%.3F" 42.42 = "42.420"); test (sprintf "%12.3F" 42.42e42 = " 4.242e+43"); test (sprintf "%.3F" 42.00 = "42.000"); @@ -297,6 +313,8 @@ try say "\nB\n%!"; test (sprintf "%B" true = "true"); test (sprintf "%B" false = "false"); + (* test (sprintf "%8B" false = " false"); *) + (* padding not done *) say "\nld/li positive\n%!"; test (sprintf "%ld/%li" 42l 43l = "42/43"); @@ -485,8 +503,8 @@ try test (sprintf "@@" = "@"); test (sprintf "@@@@" = "@@"); test (sprintf "@@%%" = "@%"); - say "\nend of tests\n%!"; + with e -> say "unexpected exception: %s\n%!" (Printexc.to_string e); test false; diff --git a/testsuite/tests/lib-format/tformat.reference b/testsuite/tests/lib-format/tformat.reference index 387dfb85..cf2b241c 100644 --- a/testsuite/tests/lib-format/tformat.reference +++ b/testsuite/tests/lib-format/tformat.reference @@ -1,91 +1,91 @@ d/i positive - 0 1 2 3 4 5 6 7 8 + 0 1 2 3 4 5 6 7 8 9 d/i negative - 9 10 11 12 13 14 15 16 17 + 10 11 12 13 14 15 16 17 18 19 u positive - 18 19 20 21 22 23 24 25 26 + 20 21 22 23 24 25 26 27 28 u negative - 27 + 29 x positive - 28 29 30 31 32 33 34 35 36 + 30 31 32 33 34 35 36 37 38 39 40 41 42 x negative - 37 + 43 X positive - 38 39 40 41 42 43 44 45 46 + 44 45 46 47 48 49 50 51 52 x negative - 47 + 53 o positive - 48 49 50 51 52 53 54 55 56 + 54 55 56 57 58 59 60 61 62 o negative - 57 + 63 s - 58 59 60 61 62 63 64 65 66 67 68 69 70 71 + 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 S - 72 73 74 75 76 77 78 79 80 + 79 80 81 82 83 84 85 86 87 88 89 90 91 c - 81 82 83 84 + 92 93 94 95 C - 85 86 87 88 89 + 96 97 98 99 100 f - 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 + 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 F - 108 109 110 111 + 119 120 121 122 123 124 125 e - 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 + 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 E - 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 + 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 B - 148 149 + 162 163 ld/li positive - 150 151 152 153 154 155 156 157 158 + 164 165 166 167 168 169 170 171 172 ld/li negative - 159 160 161 162 163 164 165 166 167 + 173 174 175 176 177 178 179 180 181 lu positive - 168 169 170 171 172 173 174 175 176 + 182 183 184 185 186 187 188 189 190 lu negative - 177 + 191 lx positive - 178 179 180 181 182 183 184 185 186 + 192 193 194 195 196 197 198 199 200 lx negative - 187 + 201 lX positive - 188 189 190 191 192 193 194 195 196 + 202 203 204 205 206 207 208 209 210 lx negative - 197 + 211 lo positive - 198 199 200 201 202 203 204 205 206 + 212 213 214 215 216 217 218 219 220 lo negative - 207 + 221 Ld/Li positive - 208 209 210 211 212 213 214 215 216 + 222 223 224 225 226 227 228 229 230 Ld/Li negative - 217 218 219 220 221 222 223 224 225 + 231 232 233 234 235 236 237 238 239 Lu positive - 226 227 228 229 230 231 232 233 234 + 240 241 242 243 244 245 246 247 248 Lu negative - 235 + 249 Lx positive - 236 237 238 239 240 241 242 243 244 + 250 251 252 253 254 255 256 257 258 Lx negative - 245 + 259 LX positive - 246 247 248 249 250 251 252 253 254 + 260 261 262 263 264 265 266 267 268 Lx negative - 255 + 269 Lo positive - 256 257 258 259 260 261 262 263 264 + 270 271 272 273 274 275 276 277 278 Lo negative - 265 + 279 a - 266 + 280 t - 267 + 281 {...%} - 268 + 282 (...%) - 269 + 283 ! % @ , and constants - 270 271 272 273 274 275 276 + 284 285 286 287 288 289 290 end of tests All tests succeeded. diff --git a/testsuite/tests/lib-printf/Makefile b/testsuite/tests/lib-printf/Makefile index dc31633e..4a74a3fd 100644 --- a/testsuite/tests/lib-printf/Makefile +++ b/testsuite/tests/lib-printf/Makefile @@ -10,11 +10,8 @@ # # ######################################################################### -#MODULES= -MAIN_MODULE=tprintf -ADD_COMPFLAGS=-I $(OTOPDIR)/testsuite/lib -ADD_MODULES=testing - +MODULES=testing BASEDIR=../.. -include $(BASEDIR)/makefiles/Makefile.one + +include $(BASEDIR)/makefiles/Makefile.several include $(BASEDIR)/makefiles/Makefile.common diff --git a/testsuite/tests/lib-printf/pr6534.ml b/testsuite/tests/lib-printf/pr6534.ml new file mode 100644 index 00000000..a356d521 --- /dev/null +++ b/testsuite/tests/lib-printf/pr6534.ml @@ -0,0 +1,19 @@ +(* these are not valid under -strict-formats, but we test them here + for backward-compatibility *) +open Printf + +let () = + printf "1 [%.5s]\n" "foo"; + printf "2 [%.*s]\n" 5 "foo"; + printf "3 [%.-5s]\n" "foo"; + printf "4 [%-.5s]\n" "foo"; + printf "5 [%-.*s]\n" 5 "foo"; + printf "6 [%.*s]\n" (-5) "foo"; + + printf "1 [%.7S]\n" "foo"; + printf "2 [%.*S]\n" 7 "foo"; + printf "3 [%.-7S]\n" "foo"; + printf "4 [%-.7S]\n" "foo"; + printf "5 [%-.*S]\n" 7 "foo"; + printf "6 [%.*S]\n" (-7) "foo"; + () diff --git a/testsuite/tests/lib-printf/pr6534.reference b/testsuite/tests/lib-printf/pr6534.reference new file mode 100644 index 00000000..c3e2a7ff --- /dev/null +++ b/testsuite/tests/lib-printf/pr6534.reference @@ -0,0 +1,14 @@ +1 [ foo] +2 [ foo] +3 [foo ] +4 [foo ] +5 [foo ] +6 [foo ] +1 [ "foo"] +2 [ "foo"] +3 ["foo" ] +4 ["foo" ] +5 ["foo" ] +6 ["foo" ] + +All tests succeeded. diff --git a/testsuite/tests/lib-printf/tprintf.ml b/testsuite/tests/lib-printf/tprintf.ml index 2922f8e3..cb4ee657 100644 --- a/testsuite/tests/lib-printf/tprintf.ml +++ b/testsuite/tests/lib-printf/tprintf.ml @@ -30,6 +30,7 @@ try (*test (sprintf "%#d/%#i" 42 43 = "42/43");*) (* >> '#' is incompatible with 'd' *) test (sprintf "%4d/%5i" 42 43 = " 42/ 43"); + test (sprintf "%*d" (-4) 42 = "42 "); test (sprintf "%*d/%*i" 4 42 5 43 = " 42/ 43"); (*test (sprintf "%-0+#4d/%-0 #5i" 42 43 = "+42 / 43 ");*) (* >> '#' is incompatible with 'd' *) @@ -43,6 +44,7 @@ try (*test (sprintf "%#d/%#i" (-42) (-43) = "-42/-43");*) (* >> '#' is incompatible with 'd' *) test (sprintf "%4d/%5i" (-42) (-43) = " -42/ -43"); + test (sprintf "%*d" (-4) (-42) = "-42 "); test (sprintf "%*d/%*i" 4 (-42) 5 (-43) = " -42/ -43"); (*test (sprintf "%-0+ #4d/%-0+ #5i" (-42) (-43) = "-42 /-43 ");*) (* >> '0' is incompatible with '-', '#' is incompatible with 'd' *) @@ -59,8 +61,7 @@ try (* >> '#' is incompatible with 'u' *) test (sprintf "%4u" 42 = " 42"); test (sprintf "%*u" 4 42 = " 42"); - (*test (sprintf "%-0+ #6d" 42 = "+42 ");*) - (* >> '-' is incompatible with '0', '#' is incompatible with 'd' *) + test (sprintf "%*u" (-4) 42 = "42 "); printf "\nu negative\n%!"; begin match Sys.word_size with @@ -82,8 +83,11 @@ try test (sprintf "%#x" 42 = "0x2a"); test (sprintf "%4x" 42 = " 2a"); test (sprintf "%*x" 5 42 = " 2a"); - (*test (sprintf "%-0+ #*x" 5 42 = "0x2a ");*) - (* >> '-' is incompatible with '0' *) + test (sprintf "%*x" (-5) 42 = "2a "); + test (sprintf "%#*x" 5 42 = " 0x2a"); + test (sprintf "%#*x" (-5) 42 = "0x2a "); + test (sprintf "%#-*x" 5 42 = "0x2a "); + test (sprintf "%-0+ #*x" 5 42 = "0x2a "); printf "\nx negative\n%!"; begin match Sys.word_size with @@ -154,6 +158,7 @@ try test (sprintf "%5s" "foo" = " foo"); test (sprintf "%1s" "foo" = "foo"); test (sprintf "%*s" 6 "foo" = " foo"); + test (sprintf "%*s" (-6) "foo" = "foo "); test (sprintf "%*s" 2 "foo" = "foo"); (*test (sprintf "%-0+ #5s" "foo" = "foo ");*) (* >> '-' is incompatible with '0', '#' is incompatible with 's' *) @@ -173,7 +178,8 @@ try (* >> '#' is incompatible with 'S' *) (* test (sprintf "%5S" "foo" = " \"foo\""); padding not done *) test (sprintf "%1S" "foo" = "\"foo\""); -(* test (sprintf "%*S" 6 "foo" = " \"foo\""); padding not done *) + test (sprintf "%*S" 8 "foo" = " \"foo\""); + test (sprintf "%*S" (-8) "foo" = "\"foo\" "); test (sprintf "%*S" 2 "foo" = "\"foo\""); (* test (sprintf "%-0+ #5S" "foo" = "\"foo\" "); padding not done *) test (sprintf "%S@" "foo" = "\"foo\"@"); @@ -222,6 +228,11 @@ try (*test (sprintf "%-0+ #12f" 42.42 = "+42.420000 ");*) (* >> '-' is incompatible with '0', '#' is incompatible with 'f' *) test (sprintf "%.3f" (-42.42) = "-42.420"); + test (sprintf "%.*f" (-3) 42.42 = "42.420"); + (* dynamically-provided negative precisions are currently silently + turned into their absolute value; we could error on this + in the future (the behavior is unspecified), but the previous + buggy output "%.0-3f-" is not desirable. *) test (sprintf "%-13.3f" (-42.42) = "-42.420 "); test (sprintf "%013.3f" (-42.42) = "-00000042.420"); test (sprintf "%+.3f" 42.42 = "+42.420"); @@ -262,7 +273,13 @@ try test (sprintf "%F" 42.42e42 =* "4.242e+43"); test (sprintf "%F" 42.00 = "42."); test (sprintf "%F" 0.042 = "0.042"); -(* no padding, no precision + test (sprintf "%4F" 3. = " 3."); + test (sprintf "%-4F" 3. = "3. "); + test (sprintf "%04F" 3. = "003."); +(* plus-padding unsupported + test (sprintf "%+4F" 3. = " +3."); +*) +(* no precision test (sprintf "%.3F" 42.42 = "42.420"); test (sprintf "%12.3F" 42.42e42 = " 4.242e+43"); test (sprintf "%.3F" 42.00 = "42.000"); diff --git a/testsuite/tests/lib-printf/tprintf.reference b/testsuite/tests/lib-printf/tprintf.reference index 11ee3a74..3a6c3f0d 100644 --- a/testsuite/tests/lib-printf/tprintf.reference +++ b/testsuite/tests/lib-printf/tprintf.reference @@ -1,91 +1,91 @@ d/i positive - 0 1 2 3 4 5 6 + 0 1 2 3 4 5 6 7 d/i negative - 7 8 9 10 11 12 13 + 8 9 10 11 12 13 14 15 u positive - 14 15 16 17 18 + 16 17 18 19 20 21 u negative - 19 + 22 x positive - 20 21 22 23 24 25 + 23 24 25 26 27 28 29 30 31 32 33 x negative - 26 + 34 X positive - 27 28 29 30 31 32 + 35 36 37 38 39 40 x negative - 33 + 41 o positive - 34 35 36 37 38 39 + 42 43 44 45 46 47 o negative - 40 + 48 s - 41 42 43 44 45 46 47 48 49 + 49 50 51 52 53 54 55 56 57 58 S - 50 51 52 53 54 55 + 59 60 61 62 63 64 65 66 c - 56 + 67 C - 57 58 + 68 69 f - 59 60 61 62 63 64 65 66 67 68 69 70 71 72 + 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 F - 73 74 75 76 + 85 86 87 88 89 90 91 e - 77 78 79 80 81 82 83 84 85 86 87 88 89 90 + 92 93 94 95 96 97 98 99 100 101 102 103 104 105 E - 91 92 93 94 95 96 97 98 99 100 101 102 103 104 + 106 107 108 109 110 111 112 113 114 115 116 117 118 119 B - 105 106 + 120 121 ld/li positive - 107 108 109 110 111 112 113 + 122 123 124 125 126 127 128 ld/li negative - 114 115 116 117 118 119 120 + 129 130 131 132 133 134 135 lu positive - 121 122 123 124 125 + 136 137 138 139 140 lu negative - 126 + 141 lx positive - 127 128 129 130 131 132 + 142 143 144 145 146 147 lx negative - 133 + 148 lX positive - 134 135 136 137 138 139 + 149 150 151 152 153 154 lx negative - 140 + 155 lo positive - 141 142 143 144 145 146 + 156 157 158 159 160 161 lo negative - 147 + 162 Ld/Li positive - 148 149 150 151 152 + 163 164 165 166 167 Ld/Li negative - 153 154 155 156 157 + 168 169 170 171 172 Lu positive - 158 159 160 161 162 + 173 174 175 176 177 Lu negative - 163 + 178 Lx positive - 164 165 166 167 168 169 + 179 180 181 182 183 184 Lx negative - 170 + 185 LX positive - 171 172 173 174 175 176 + 186 187 188 189 190 191 Lx negative - 177 + 192 Lo positive - 178 179 180 181 182 183 + 193 194 195 196 197 198 Lo negative - 184 + 199 a - 185 + 200 t - 186 + 201 {...%} - 187 + 202 (...%) - 188 + 203 ! % @ , and constants - 189 190 191 192 193 194 195 + 204 205 206 207 208 209 210 end of tests All tests succeeded. diff --git a/testsuite/tests/lib-scanf/tscanf.ml b/testsuite/tests/lib-scanf/tscanf.ml index 8e6a252b..33054b66 100644 --- a/testsuite/tests/lib-scanf/tscanf.ml +++ b/testsuite/tests/lib-scanf/tscanf.ml @@ -1439,6 +1439,8 @@ let test58 () = test (test58 ()) ;; +(* skip test number "59" which is commented below *) +let () = test (true);; (* let test59 () = ;; @@ -1470,3 +1472,15 @@ let scan_record scan_field ib = let scan_field ib = bscanf ib "%s = %[^;]" (fun finame ficont -> finame, ficont);; *) + +(* testing formats that do not consume their input *) +let test60 () = + sscanf "abc" "%0c%0c%c%n" (fun c1 c2 c3 n -> + c1 = 'a' && c2 = 'a' && c3 = 'a' && n = 1) + && + sscanf "abc" "%0s%s" (fun s1 s2 -> s1 = "" && s2 = "abc") + && + sscanf "abc" "%1s%s" (fun s1 s2 -> s1 = "a" && s2 = "bc") +;; + +test (test60 ()); diff --git a/testsuite/tests/lib-scanf/tscanf.reference b/testsuite/tests/lib-scanf/tscanf.reference index 18fe92ba..5b2859cb 100644 --- a/testsuite/tests/lib-scanf/tscanf.reference +++ b/testsuite/tests/lib-scanf/tscanf.reference @@ -1,2 +1,2 @@ - 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 + 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 All tests succeeded. diff --git a/testsuite/tests/tool-debugger/basic/Makefile b/testsuite/tests/tool-debugger/basic/Makefile index f95b4803..3c171390 100644 --- a/testsuite/tests/tool-debugger/basic/Makefile +++ b/testsuite/tests/tool-debugger/basic/Makefile @@ -10,7 +10,7 @@ # # ######################################################################### -BASEDIR=../.. +BASEDIR=../../.. MAIN_MODULE=debuggee ADD_COMPFLAGS=-g -custom LD_PATH=$(TOPDIR)/otherlibs/$(UNIXLIBVAR)unix diff --git a/testsuite/tests/tool-debugger/no_debug_event/.ignore b/testsuite/tests/tool-debugger/no_debug_event/.ignore new file mode 100644 index 00000000..cfbcf5c6 --- /dev/null +++ b/testsuite/tests/tool-debugger/no_debug_event/.ignore @@ -0,0 +1,4 @@ +compiler-libs +out +c +c.exe diff --git a/testsuite/tests/tool-debugger/no_debug_event/Makefile b/testsuite/tests/tool-debugger/no_debug_event/Makefile new file mode 100644 index 00000000..c9a08d25 --- /dev/null +++ b/testsuite/tests/tool-debugger/no_debug_event/Makefile @@ -0,0 +1,57 @@ +######################################################################### +# # +# OCaml # +# # +# Damien Doligez, EPI Gallium, INRIA Rocquencourt # +# # +# Copyright 2013 Institut National de Recherche en Informatique et # +# en Automatique. All rights reserved. This file is distributed # +# under the terms of the Q Public License version 1.0. # +# # +######################################################################### + +BASEDIR=../../.. +ADD_COMPFLAGS=-g -custom +LD_PATH=$(TOPDIR)/otherlibs/$(UNIXLIBVAR)unix + +.PHONY: default +default: + @if ! $(SUPPORTS_SHARED_LIBRARIES); then \ + echo 'skipped (shared libraries not available)'; \ + else \ + $(MAKE) compile; \ + $(SET_LD_PATH) OCAMLLIB=. $(MAKE) run; \ + fi + +.PHONY: compile +compile: $(ML_FILES) $(CMO_FILES) + @rm -f c$(EXE) + @$(OCAMLC) $(ADD_COMPFLAGS) -c a.ml -for-pack foo + @$(OCAMLC) $(ADD_COMPFLAGS) a.cmo -pack -o foo.cmo + @$(OCAMLC) $(ADD_COMPFLAGS) -c b.ml + @$(OCAMLC) $(ADD_COMPFLAGS) foo.cmo b.cmo -o c$(EXE) + @mkdir -p compiler-libs + @cp $(TOPDIR)/toplevel/topdirs.cmi compiler-libs/ + +.PHONY: run +run: + @printf " ... testing with ocamlc" + @rm -f noev.result + @echo 'source input_script' | \ + $(OCAMLRUN) `$(CYGPATH) $(TOPDIR)/debugger/ocamldebug$(EXE)` \ + c$(EXE) >noev.raw.result 2>&1 \ + && sed -e '/Debugger version/d' -e '/^Time:/d' \ + -e '/Breakpoint [0-9]* at [0-9]*:/d' -e '$$d' \ + noev.raw.result >noev.result \ + && $(DIFF) noev.reference noev.result >/dev/null \ + && echo " => passed" || echo " => failed" + +.PHONY: promote +promote: defaultpromote + +.PHONY: clean +clean: defaultclean + @rm -f *.result *.cm* c$(EXE) + @rm -rf compiler-libs + +include $(BASEDIR)/makefiles/Makefile.common diff --git a/testsuite/tests/tool-debugger/no_debug_event/a.ml b/testsuite/tests/tool-debugger/no_debug_event/a.ml new file mode 100644 index 00000000..0547b3d0 --- /dev/null +++ b/testsuite/tests/tool-debugger/no_debug_event/a.ml @@ -0,0 +1 @@ +let x = 1 diff --git a/testsuite/tests/tool-debugger/no_debug_event/b.ml b/testsuite/tests/tool-debugger/no_debug_event/b.ml new file mode 100644 index 00000000..83502097 --- /dev/null +++ b/testsuite/tests/tool-debugger/no_debug_event/b.ml @@ -0,0 +1,3 @@ +let () = + print_int Foo.A.x; + print_newline () diff --git a/testsuite/tests/tool-debugger/no_debug_event/input_script b/testsuite/tests/tool-debugger/no_debug_event/input_script new file mode 100644 index 00000000..58afc787 --- /dev/null +++ b/testsuite/tests/tool-debugger/no_debug_event/input_script @@ -0,0 +1,2 @@ +run +quit diff --git a/testsuite/tests/tool-debugger/no_debug_event/noev.reference b/testsuite/tests/tool-debugger/no_debug_event/noev.reference new file mode 100644 index 00000000..d4a69fc9 --- /dev/null +++ b/testsuite/tests/tool-debugger/no_debug_event/noev.reference @@ -0,0 +1,4 @@ + +(ocd) Loading program... done. +1 +Program exit. diff --git a/testsuite/tests/typing-extensions/open_types.ml.reference b/testsuite/tests/typing-extensions/open_types.ml.reference index 5fb9684d..841a94ba 100644 --- a/testsuite/tests/typing-extensions/open_types.ml.reference +++ b/testsuite/tests/typing-extensions/open_types.ml.reference @@ -76,7 +76,9 @@ Error: Signature mismatch: ^^^^^^^^^^^^^^^^^^ Warning 8: this pattern-matching is not exhaustive. Here is an example of a value that is not matched: -*extension* +_ +Matching over values of open types must include +a wild card pattern in order to be exhaustive. type foo = .. type foo += Foo val f : foo -> unit = <fun> diff --git a/testsuite/tests/typing-modules-bugs/pr6572_ok.ml b/testsuite/tests/typing-modules-bugs/pr6572_ok.ml new file mode 100644 index 00000000..00c2f091 --- /dev/null +++ b/testsuite/tests/typing-modules-bugs/pr6572_ok.ml @@ -0,0 +1,19 @@ +module type S = sig + include Set.S + module E : sig val x : int end +end + +module Make(O : Set.OrderedType) : S with type elt = O.t = + struct + include Set.Make(O) + module E = struct let x = 1 end + end + +module rec A : Set.OrderedType = struct + type t = int + let compare = Pervasives.compare +end +and B : S = struct + module C = Make(A) + include C +end diff --git a/testsuite/tests/typing-modules/aliases.ml b/testsuite/tests/typing-modules/aliases.ml index 3eca5271..7580bebe 100644 --- a/testsuite/tests/typing-modules/aliases.ml +++ b/testsuite/tests/typing-modules/aliases.ml @@ -235,3 +235,12 @@ module R = struct module Q = M end;; module R' : S = R;; (* should be ok *) + +(* PR#6578 *) + +module M = struct let f x = x end +module rec R : sig module M : sig val f : 'a -> 'a end end = + struct module M = M end;; +R.M.f 3;; +module rec R : sig module M = M end = struct module M = M end;; +R.M.f 3;; diff --git a/testsuite/tests/typing-modules/aliases.ml.reference b/testsuite/tests/typing-modules/aliases.ml.reference index 2bb3231d..6f0fe745 100644 --- a/testsuite/tests/typing-modules/aliases.ml.reference +++ b/testsuite/tests/typing-modules/aliases.ml.reference @@ -411,4 +411,9 @@ Error: Signature mismatch: sig module N = M.N module P = M.P end In module Q.N: Modules do not match: sig end is not included in (module M.N) +# module M : sig val f : 'a -> 'a end +module rec R : sig module M : sig val f : 'a -> 'a end end +# - : int = 3 +# module rec R : sig module M = M end +# - : int = 3 # diff --git a/testsuite/tests/typing-short-paths/short-paths.ml b/testsuite/tests/typing-short-paths/short-paths.ml index 56160906..a9812f4f 100644 --- a/testsuite/tests/typing-short-paths/short-paths.ml +++ b/testsuite/tests/typing-short-paths/short-paths.ml @@ -46,3 +46,9 @@ module M1 = struct type u = v and v = t1 end;; module N1 = struct type u = v and v = M1.v end;; type t1 = B;; module N2 = struct type u = v and v = M1.v end;; + + +(* PR#6566 *) +module type PR6566 = sig type t = string end;; +module PR6566 = struct type t = int end;; +module PR6566' : PR6566 = PR6566;; diff --git a/testsuite/tests/typing-short-paths/short-paths.ml.reference b/testsuite/tests/typing-short-paths/short-paths.ml.reference index 657a5214..53309ad3 100644 --- a/testsuite/tests/typing-short-paths/short-paths.ml.reference +++ b/testsuite/tests/typing-short-paths/short-paths.ml.reference @@ -69,4 +69,15 @@ type u = M.u = C # module N1 : sig type u = v and v = t1 end # type t1 = B # module N2 : sig type u = v and v = N1.v end +# module type PR6566 = sig type t = bytes end +# module PR6566 : sig type t = int end +# Characters 26-32: + module PR6566' : PR6566 = PR6566;; + ^^^^^^ +Error: Signature mismatch: + Modules do not match: sig type t = int end is not included in PR6566 + Type declarations do not match: + type t = int + is not included in + type t = bytes # diff --git a/tools/.depend b/tools/.depend index b0407009..c33f5c6f 100644 --- a/tools/.depend +++ b/tools/.depend @@ -1,4 +1,4 @@ -depend.cmi : ../parsing/parsetree.cmi +depend.cmi : ../parsing/parsetree.cmi ../parsing/longident.cmi profiling.cmi : tast_iter.cmi : ../typing/typedtree.cmi ../parsing/asttypes.cmi untypeast.cmi : ../typing/typedtree.cmi ../typing/path.cmi \ @@ -52,11 +52,13 @@ ocaml299to3.cmx : ocamlcp.cmo : ../driver/main_args.cmi ocamlcp.cmx : ../driver/main_args.cmx ocamldep.cmo : ../driver/pparse.cmi ../parsing/parsetree.cmi \ - ../parsing/parse.cmi ../utils/misc.cmi ../parsing/location.cmi depend.cmi \ - ../utils/config.cmi ../driver/compenv.cmi ../utils/clflags.cmi + ../parsing/parse.cmi ../utils/misc.cmi ../parsing/longident.cmi \ + ../parsing/location.cmi depend.cmi ../utils/config.cmi \ + ../driver/compenv.cmi ../utils/clflags.cmi ocamldep.cmx : ../driver/pparse.cmx ../parsing/parsetree.cmi \ - ../parsing/parse.cmx ../utils/misc.cmx ../parsing/location.cmx depend.cmx \ - ../utils/config.cmx ../driver/compenv.cmx ../utils/clflags.cmx + ../parsing/parse.cmx ../utils/misc.cmx ../parsing/longident.cmx \ + ../parsing/location.cmx depend.cmx ../utils/config.cmx \ + ../driver/compenv.cmx ../utils/clflags.cmx ocamlmklib.cmo : ocamlmklibconfig.cmo ocamlmklib.cmx : ocamlmklibconfig.cmx ocamlmklibconfig.cmo : diff --git a/tools/depend.ml b/tools/depend.ml index c6dc1433..aeb121cb 100644 --- a/tools/depend.ml +++ b/tools/depend.ml @@ -21,20 +21,21 @@ module StringSet = Set.Make(struct type t = string let compare = compare end) let free_structure_names = ref StringSet.empty -let rec addmodule bv lid = - match lid with - Lident s -> +let rec add_path bv = function + | Lident s -> if not (StringSet.mem s bv) then free_structure_names := StringSet.add s !free_structure_names - | Ldot(l, _s) -> addmodule bv l - | Lapply(l1, l2) -> addmodule bv l1; addmodule bv l2 + | Ldot(l, _s) -> add_path bv l + | Lapply(l1, l2) -> add_path bv l1; add_path bv l2 + +let open_module bv lid = add_path bv lid let add bv lid = match lid.txt with - Ldot(l, _s) -> addmodule bv l + Ldot(l, _s) -> add_path bv l | _ -> () -let addmodule bv lid = addmodule bv lid.txt +let addmodule bv lid = add_path bv lid.txt let rec add_type bv ty = match ty.ptyp_desc with @@ -192,7 +193,7 @@ let rec add_expr bv exp = let bv = add_pattern bv pat in List.iter (add_class_field bv) fieldl | Pexp_newtype (_, e) -> add_expr bv e | Pexp_pack m -> add_module bv m - | Pexp_open (_ovf, m, e) -> addmodule bv m; add_expr bv e + | Pexp_open (_ovf, m, e) -> open_module bv m.txt; add_expr bv e | Pexp_extension _ -> () and add_cases bv cases = @@ -260,7 +261,7 @@ and add_sig_item bv item = end; bv | Psig_open od -> - addmodule bv od.popen_lid; bv + open_module bv od.popen_lid.txt; bv | Psig_include incl -> add_modtype bv incl.pincl_mod; bv | Psig_class cdl -> @@ -321,7 +322,7 @@ and add_struct_item bv item = end; bv | Pstr_open od -> - addmodule bv od.popen_lid; bv + open_module bv od.popen_lid.txt; bv | Pstr_class cdl -> List.iter (add_class_declaration bv) cdl; bv | Pstr_class_type cdtl -> diff --git a/tools/depend.mli b/tools/depend.mli index f859cfef..93fc084f 100644 --- a/tools/depend.mli +++ b/tools/depend.mli @@ -16,6 +16,8 @@ module StringSet : Set.S with type elt = string val free_structure_names : StringSet.t ref +val open_module : StringSet.t -> Longident.t -> unit + val add_use_file : StringSet.t -> Parsetree.toplevel_phrase list -> unit val add_signature : StringSet.t -> Parsetree.signature -> unit diff --git a/tools/ocamldep.ml b/tools/ocamldep.ml index 59fecc41..db0695c9 100644 --- a/tools/ocamldep.ml +++ b/tools/ocamldep.ml @@ -56,18 +56,21 @@ let readdir dir = dirs := StringMap.add dir contents !dirs; contents +let add_to_list li s = + li := s :: !li + let add_to_load_path dir = try let dir = Misc.expand_directory Config.standard_library dir in let contents = readdir dir in - load_path := (dir, contents) :: !load_path + add_to_list load_path (dir, contents) with Sys_error msg -> Format.fprintf Format.err_formatter "@[Bad -I option: %s@]@." msg; error_occurred := true let add_to_synonym_list synonyms suffix = if (String.length suffix) > 1 && suffix.[0] = '.' then - synonyms := suffix :: !synonyms + add_to_list synonyms suffix else begin Format.fprintf Format.err_formatter "@[Bad suffix: '%s'@]@." suffix; error_occurred := true @@ -220,8 +223,14 @@ let read_parse_and_extract parse_function extract_function magic source_file = let input_file = Pparse.preprocess source_file in begin try let ast = - Pparse.file ~tool_name Format.err_formatter input_file parse_function magic in - extract_function Depend.StringSet.empty ast; + Pparse.file ~tool_name Format.err_formatter + input_file parse_function magic + in + let bound_vars = Depend.StringSet.empty in + List.iter (fun modname -> + Depend.open_module bound_vars (Longident.Lident modname) + ) !Clflags.open_modules; + extract_function bound_vars ast; Pparse.remove_preprocessed input_file; !Depend.free_structure_names with x -> @@ -405,14 +414,14 @@ let print_version_num () = let _ = Clflags.classic := false; - first_include_dirs := Filename.current_dir_name :: !first_include_dirs; + add_to_list first_include_dirs Filename.current_dir_name; Compenv.readenv ppf Before_args; Arg.parse [ "-absname", Arg.Set Location.absname, " Show absolute filenames in error messages"; "-all", Arg.Set all_dependencies, " Generate dependencies on all files"; - "-I", Arg.String (fun s -> Clflags.include_dirs := s :: !Clflags.include_dirs), + "-I", Arg.String (add_to_list Clflags.include_dirs), "<dir> Add <dir> to the list of include directories"; "-impl", Arg.String (file_dependencies_as ML), "<f> Process <f> as a .ml file"; @@ -428,9 +437,11 @@ let _ = " Generate dependencies for native-code only (no .cmo files)"; "-one-line", Arg.Set one_line, " Output one line per file, regardless of the length"; + "-open", Arg.String (add_to_list Clflags.open_modules), + "<module> Opens the module <module> before typing"; "-pp", Arg.String(fun s -> Clflags.preprocessor := Some s), "<cmd> Pipe sources through preprocessor <cmd>"; - "-ppx", Arg.String(fun s -> first_ppx := s :: !first_ppx), + "-ppx", Arg.String (add_to_list first_ppx), "<cmd> Pipe abstract syntax trees through preprocessor <cmd>"; "-slash", Arg.Set Clflags.force_slash, " (Windows) Use forward slash / instead of backslash \\ in file paths"; diff --git a/toplevel/topdirs.ml b/toplevel/topdirs.ml index d3387a3f..4773c3f0 100644 --- a/toplevel/topdirs.ml +++ b/toplevel/topdirs.ml @@ -62,7 +62,7 @@ let check_consistency ppf filename cu = try List.iter (fun (name, crco) -> - Env.imported_units := name :: !Env.imported_units; + Env.add_import name; match crco with None -> () | Some crc-> @@ -271,6 +271,8 @@ let dir_trace ppf lid = (* Nothing to do if it's not a closure *) if Obj.is_block clos && (Obj.tag clos = Obj.closure_tag || Obj.tag clos = Obj.infix_tag) + && (match Ctype.(repr (expand_head !toplevel_env desc.val_type)) + with {desc=Tarrow _} -> true | _ -> false) then begin match is_traced clos with | Some opath -> diff --git a/toplevel/toploop.ml b/toplevel/toploop.ml index 482150a1..9fa802ca 100644 --- a/toplevel/toploop.ml +++ b/toplevel/toploop.ml @@ -323,11 +323,14 @@ let protect r newval body = let use_print_results = ref true -let phrase ppf phr = +let preprocess_phrase ppf phr = let phr = match phr with | Ptop_def str -> - Ptop_def (Pparse.apply_rewriters ~tool_name:"ocaml" ast_impl_magic_number str) + let str = + Pparse.apply_rewriters_str ~restore:true ~tool_name:"ocaml" str + in + Ptop_def str | phr -> phr in if !Clflags.dump_parsetree then Printast.top_phrase ppf phr; @@ -354,7 +357,7 @@ let use_file ppf wrap_mod name = try List.iter (fun ph -> - let ph = phrase ppf ph in + let ph = preprocess_phrase ppf ph in if not (execute_phrase !use_print_results ppf ph) then raise Exit) (if wrap_mod then parse_mod_use_file name lb @@ -429,7 +432,7 @@ let _ = Compmisc.init_path false; List.iter (fun (name, crco) -> - Env.imported_units := name :: !Env.imported_units; + Env.add_import name; match crco with None -> () | Some crc-> @@ -480,7 +483,7 @@ let loop ppf = Location.reset(); first_line := true; let phr = try !parse_toplevel_phrase lb with Exit -> raise PPerror in - let phr = phrase ppf phr in + let phr = preprocess_phrase ppf phr in Env.reset_cache_toplevel (); ignore(execute_phrase true ppf phr) with diff --git a/toplevel/toploop.mli b/toplevel/toploop.mli index 5f0b86e2..1867c001 100644 --- a/toplevel/toploop.mli +++ b/toplevel/toploop.mli @@ -53,6 +53,9 @@ val execute_phrase : bool -> formatter -> Parsetree.toplevel_phrase -> bool 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 preprocess_phrase : formatter -> Parsetree.toplevel_phrase -> Parsetree.toplevel_phrase + (* Preprocess the given toplevel phrase using regular and ppx + preprocessors. Return the updated phrase. *) val use_file : formatter -> string -> bool val use_silently : formatter -> string -> bool val mod_use_file : formatter -> string -> bool diff --git a/toplevel/topmain.ml b/toplevel/topmain.ml index d1dbeca9..0d8f2d4c 100644 --- a/toplevel/topmain.ml +++ b/toplevel/topmain.ml @@ -41,6 +41,7 @@ let file_argument name = let newargs = Array.sub Sys.argv !Arg.current (Array.length Sys.argv - !Arg.current) in + Compenv.readenv ppf Before_link; if prepare ppf && Toploop.run_script ppf name newargs then exit 0 else exit 2 diff --git a/typing/env.ml b/typing/env.ml index c5c3a5ff..7df15660 100644 --- a/typing/env.ml +++ b/typing/env.ml @@ -296,6 +296,7 @@ type pers_struct = ps_sig: signature; ps_comps: module_components; ps_crcs: (string * Digest.t option) list; + mutable ps_crcs_checked: bool; ps_filename: string; ps_flags: pers_flags list } @@ -305,22 +306,31 @@ let persistent_structures = (* Consistency between persistent structures *) let crc_units = Consistbl.create() -let imported_units = ref ([] : string list) + +module StringSet = + Set.Make(struct type t = string let compare = String.compare end) + +let imported_units = ref StringSet.empty + +let add_import s = + imported_units := StringSet.add s !imported_units let clear_imports () = Consistbl.clear crc_units; - imported_units := [] + imported_units := StringSet.empty let check_consistency ps = + if not ps.ps_crcs_checked then try List.iter (fun (name, crco) -> match crco with None -> () | Some crc -> - imported_units := name :: !imported_units; + add_import name; Consistbl.check crc_units name crc ps.ps_filename) - ps.ps_crcs + ps.ps_crcs; + ps.ps_crcs_checked <- true; with Consistbl.Inconsistency(name, source, auth) -> error (Inconsistent_import(name, auth, source)) @@ -342,10 +352,12 @@ let read_pers_struct modname filename = ps_comps = comps; ps_crcs = crcs; ps_filename = filename; - ps_flags = flags } in + ps_flags = flags; + ps_crcs_checked = false; + } in if ps.ps_name <> modname then error (Illegal_renaming(modname, ps.ps_name, filename)); - imported_units := name :: !imported_units; + add_import name; List.iter (function Rectypes -> if not !Clflags.recursive_types then @@ -1597,7 +1609,7 @@ let crc_of_unit name = (* Return the list of imported interfaces with their CRCs *) let imports() = - Consistbl.extract !imported_units crc_units + Consistbl.extract (StringSet.elements !imported_units) crc_units (* Save a signature to a file *) @@ -1628,10 +1640,12 @@ let save_signature_with_imports sg modname filename imports = ps_comps = comps; ps_crcs = (cmi.cmi_name, Some crc) :: imports; ps_filename = filename; - ps_flags = cmi.cmi_flags } in + ps_flags = cmi.cmi_flags; + ps_crcs_checked = false; + } in Hashtbl.add persistent_structures modname (Some ps); Consistbl.set crc_units modname crc filename; - imported_units := modname :: !imported_units; + add_import modname; sg with exn -> close_out oc; diff --git a/typing/env.mli b/typing/env.mli index 4db5a847..ed2f6f1c 100644 --- a/typing/env.mli +++ b/typing/env.mli @@ -168,7 +168,7 @@ val imports: unit -> (string * Digest.t option) list (* Direct access to the table of imported compilation units with their CRC *) val crc_units: Consistbl.t -val imported_units: string list ref +val add_import: string -> unit (* Summaries -- compact representation of an environment, to be exported in debugging information. *) diff --git a/typing/includemod.ml b/typing/includemod.ml index 223214f3..91f37d7c 100644 --- a/typing/includemod.ml +++ b/typing/includemod.ml @@ -61,12 +61,12 @@ let value_descriptions env cxt subst id vd1 vd2 = (* Inclusion between type declarations *) -let type_declarations env cxt subst id decl1 decl2 = +let type_declarations env ?(old_env=env) cxt subst id decl1 decl2 = Env.mark_type_used env (Ident.name id) decl1; let decl2 = Subst.type_declaration subst decl2 in let err = Includecore.type_declarations env (Ident.name id) decl1 id decl2 in if err <> [] then - raise(Error[cxt, env, Type_declarations(id, decl1, decl2, err)]) + raise(Error[cxt, old_env, Type_declarations(id, decl1, decl2, err)]) (* Inclusion between extension constructors *) @@ -78,19 +78,20 @@ let extension_constructors env cxt subst id ext1 ext2 = (* Inclusion between class declarations *) -let class_type_declarations env cxt subst id decl1 decl2 = +let class_type_declarations ~old_env env cxt subst id decl1 decl2 = let decl2 = Subst.cltype_declaration subst decl2 in match Includeclass.class_type_declarations env decl1 decl2 with [] -> () | reason -> - raise(Error[cxt, env, Class_type_declarations(id, decl1, decl2, reason)]) + raise(Error[cxt, old_env, + Class_type_declarations(id, decl1, decl2, reason)]) -let class_declarations env cxt subst id decl1 decl2 = +let class_declarations ~old_env env cxt subst id decl1 decl2 = let decl2 = Subst.class_declaration subst decl2 in match Includeclass.class_declarations env decl1 decl2 with [] -> () | reason -> - raise(Error[cxt, env, Class_declarations(id, decl1, decl2, reason)]) + raise(Error[cxt, old_env, Class_declarations(id, decl1, decl2, reason)]) (* Expand a module type identifier when possible *) @@ -314,7 +315,7 @@ and signatures env cxt subst sig1 sig2 = begin match unpaired with [] -> let cc = - signature_components new_env cxt subst (List.rev paired) + signature_components env new_env cxt subst (List.rev paired) in if len1 = len2 then (* see PR#5098 *) simplify_structure_coercion cc id_pos_list @@ -363,36 +364,38 @@ and signatures env cxt subst sig1 sig2 = (* Inclusion between signature components *) -and signature_components env cxt subst = function +and signature_components old_env env cxt subst paired = + let comps_rec rem = signature_components old_env env cxt subst rem in + match paired with [] -> [] | (Sig_value(id1, valdecl1), Sig_value(id2, valdecl2), pos) :: rem -> let cc = value_descriptions env cxt subst id1 valdecl1 valdecl2 in begin match valdecl2.val_kind with - Val_prim p -> signature_components env cxt subst rem - | _ -> (pos, cc) :: signature_components env cxt subst rem + Val_prim p -> comps_rec rem + | _ -> (pos, cc) :: comps_rec rem end | (Sig_type(id1, tydecl1, _), Sig_type(id2, tydecl2, _), pos) :: rem -> - type_declarations env cxt subst id1 tydecl1 tydecl2; - signature_components env cxt subst rem + type_declarations ~old_env env cxt subst id1 tydecl1 tydecl2; + comps_rec rem | (Sig_typext(id1, ext1, _), Sig_typext(id2, ext2, _), pos) :: rem -> extension_constructors env cxt subst id1 ext1 ext2; - (pos, Tcoerce_none) :: signature_components env cxt subst rem + (pos, Tcoerce_none) :: comps_rec rem | (Sig_module(id1, mty1, _), Sig_module(id2, mty2, _), pos) :: rem -> let cc = modtypes env (Module id1::cxt) subst (Mtype.strengthen env mty1.md_type (Pident id1)) mty2.md_type in - (pos, cc) :: signature_components env cxt subst rem + (pos, cc) :: comps_rec rem | (Sig_modtype(id1, info1), Sig_modtype(id2, info2), pos) :: rem -> modtype_infos env cxt subst id1 info1 info2; - signature_components env cxt subst rem + comps_rec rem | (Sig_class(id1, decl1, _), Sig_class(id2, decl2, _), pos) :: rem -> - class_declarations env cxt subst id1 decl1 decl2; - (pos, Tcoerce_none) :: signature_components env cxt subst rem + class_declarations ~old_env env cxt subst id1 decl1 decl2; + (pos, Tcoerce_none) :: comps_rec rem | (Sig_class_type(id1, info1, _), Sig_class_type(id2, info2, _), pos) :: rem -> - class_type_declarations env cxt subst id1 info1 info2; - signature_components env cxt subst rem + class_type_declarations ~old_env env cxt subst id1 info1 info2; + comps_rec rem | _ -> assert false @@ -540,7 +543,7 @@ let rec context ppf = function | Modtype id :: rem -> fprintf ppf "@[<2>module type %a =@ %a@]" ident id context_mty rem | Body x :: rem -> - fprintf ppf "functor (%a) ->@ %a" ident x context_mty rem + fprintf ppf "functor (%s) ->@ %a" (argname x) context_mty rem | Arg x :: rem -> fprintf ppf "functor (%a : %a) -> ..." ident x context_mty rem | [] -> @@ -551,11 +554,14 @@ and context_mty ppf = function | cxt -> context ppf cxt and args ppf = function Body x :: rem -> - fprintf ppf "(%a)%a" ident x args rem + fprintf ppf "(%s)%a" (argname x) args rem | Arg x :: rem -> fprintf ppf "(%a :@ %a) : ..." ident x context_mty rem | cxt -> fprintf ppf " :@ %a" context_mty cxt +and argname x = + let s = Ident.name x in + if s = "*" then "" else s let path_of_context = function Module id :: rem -> diff --git a/typing/mtype.ml b/typing/mtype.ml index dd766a91..21d6b871 100644 --- a/typing/mtype.ml +++ b/typing/mtype.ml @@ -350,7 +350,9 @@ let rec remove_aliases env excl mty = Mty_signature sg -> Mty_signature (remove_aliases_sig env excl sg) | Mty_alias _ -> - remove_aliases env excl (Env.scrape_alias env mty) + let mty' = Env.scrape_alias env mty in + if mty' = mty then mty else + remove_aliases env excl mty' | mty -> mty diff --git a/typing/parmatch.ml b/typing/parmatch.ml index 17297974..6732be7a 100644 --- a/typing/parmatch.ml +++ b/typing/parmatch.ml @@ -1809,7 +1809,11 @@ let do_check_partial ?pred exhaust loc casel pss = match pss with None -> Total | Some v -> let errmsg = - try + match v.pat_desc with + Tpat_construct (_, {cstr_name="*extension*"}, _) -> + "_\nMatching over values of open types must include\n\ + a wild card pattern in order to be exhaustive." + | _ -> try let buf = Buffer.create 16 in let fmt = formatter_of_buffer buf in top_pretty fmt v; @@ -1825,9 +1829,11 @@ let do_check_partial ?pred exhaust loc casel pss = match pss with end ; Buffer.contents buf with _ -> - "" in + "" + in Location.prerr_warning loc (Warnings.Partial_match errmsg) ; - Partial end + Partial + end | _ -> fatal_error "Parmatch.check_partial" end diff --git a/typing/typecore.ml b/typing/typecore.ml index 16a310d6..b173d99c 100644 --- a/typing/typecore.ml +++ b/typing/typecore.ml @@ -2905,6 +2905,8 @@ and type_format loc str env = mk_constr "Ignored_scan_get_counter" [ mk_counter counter ] + | Ignored_scan_next_char -> + mk_constr "Ignored_scan_next_char" [] and mk_padding : type x y . (x, y) padding -> Parsetree.expression = fun pad -> match pad with | No_padding -> mk_constr "No_padding" [] @@ -2970,6 +2972,8 @@ and type_format loc str env = mk_int_opt width_opt; mk_string char_set; mk_fmt rest ] | Scan_get_counter (cnt, rest) -> mk_constr "Scan_get_counter" [ mk_counter cnt; mk_fmt rest ] + | Scan_next_char rest -> + mk_constr "Scan_next_char" [ mk_fmt rest ] | Ignored_param (ign, rest) -> mk_constr "Ignored_param" [ mk_ignored ign; mk_fmt rest ] | End_of_format -> diff --git a/utils/consistbl.ml b/utils/consistbl.ml index 6adaf411..37f6a2b1 100644 --- a/utils/consistbl.ml +++ b/utils/consistbl.ml @@ -41,12 +41,9 @@ let set tbl name crc source = Hashtbl.add tbl name (crc, source) let source tbl name = snd (Hashtbl.find tbl name) let extract l tbl = + let l = List.sort_uniq String.compare l in List.fold_left (fun assc name -> - try - ignore (List.assoc name assc); - assc - with Not_found -> try let (crc, _) = Hashtbl.find tbl name in (name, Some crc) :: assc diff --git a/utils/misc.ml b/utils/misc.ml index 898880cb..2eb8088e 100644 --- a/utils/misc.ml +++ b/utils/misc.ml @@ -87,6 +87,22 @@ let find_in_path path name = in try_dir path end +let find_in_path_rel path name = + let rec simplify s = + let open Filename in + let base = basename s in + let dir = dirname s in + if dir = s then dir + else if base = current_dir_name then simplify dir + else concat (simplify dir) base + in + let rec try_dir = function + [] -> raise Not_found + | dir::rem -> + let fullname = simplify (Filename.concat dir name) in + if Sys.file_exists fullname then fullname else try_dir rem + in try_dir path + let find_in_path_uncap path name = let uname = String.uncapitalize name in let rec try_dir = function diff --git a/utils/misc.mli b/utils/misc.mli index 4a3c84b2..5168a6a9 100644 --- a/utils/misc.mli +++ b/utils/misc.mli @@ -42,6 +42,8 @@ val may_map: ('a -> 'b) -> 'a option -> 'b option val find_in_path: string list -> string -> string (* Search a file in a list of directories. *) +val find_in_path_rel: string list -> string -> string + (* Search a relative file in a list of directories. *) val find_in_path_uncap: string list -> string -> string (* Same, but search also for uncapitalized name, i.e. if name is Foo.ml, allow /path/Foo.ml and /path/foo.ml