diff options
82 files changed, 1133 insertions, 497 deletions
@@ -537,20 +537,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 \ @@ -22,22 +22,76 @@ Type system: This is done by adding equations to submodules when expanding aliases. In theory this may be incompatible is some corner cases defining a module type through inference, but no breakage known on published code. -- PR#6593: Functor application in tests/basic-modules fails after commit 15405 +- PR#6593: Functor application in tests/basic-modules fails after commit 15405 OCaml 4.02.1: ------------- -- PR#4099: Bug in Makefile.nt: won't stop on error (George Necula) -- PR#6181: Improve MSVC build (Chen Gang) +(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) -- PR#6554: fix race condition when retrieving backtraces (Jérémie Dimino, - Mark Shinwell). + (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: ------------- @@ -148,7 +202,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 @@ -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 @@ -1,4 +1,4 @@ -4.03.0+dev4-2014-09-26 +4.03.0+dev5-2014-10-15 # The version string is the first line of this file. # It must be in the format described in stdlib/sys.mli diff --git a/asmrun/signals_osdep.h b/asmrun/signals_osdep.h index 23165ad680..f3b4642d2d 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/bytecomp/bytegen.ml b/bytecomp/bytegen.ml index be884ded5f..e08a7c3e02 100644 --- a/bytecomp/bytegen.ml +++ b/bytecomp/bytegen.ml @@ -445,7 +445,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 3348f46dcd..05ebac9aad 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 77df46110e..e9a977656d 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 4ad8e9b4e1..5d9fb593fa 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 14f8b0659f..5e07978305 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 1f475565f9..89be6f5da1 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/config/s-nt.h b/config/s-nt.h index 603b05054c..ccf1bf4c57 100644 --- a/config/s-nt.h +++ b/config/s-nt.h @@ -30,3 +30,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 d0748ae291..383b401557 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(). */ @@ -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 @@ -635,7 +639,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" @@ -747,6 +751,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;; @@ -779,6 +784,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 @@ -1026,11 +1032,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*) @@ -1294,6 +1306,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 @@ -1309,7 +1326,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;; *) @@ -1345,6 +1363,8 @@ 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 @@ -1375,7 +1395,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 diff --git a/debugger/source.ml b/debugger/source.ml index af69fbc7bf..aa9ec70831 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 4f9668c750..7636abe030 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 95b7c69e38..18ade80bae 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/emacs/caml-types.el b/emacs/caml-types.el index 47060a2cf7..4bc2266557 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/ocamlbuild/ocaml_specific.ml b/ocamlbuild/ocaml_specific.ml index 037d119e6f..79517a86a4 100644 --- a/ocamlbuild/ocaml_specific.ml +++ b/ocamlbuild/ocaml_specific.ml @@ -670,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 5ee512200f..5193b9b904 100644 --- a/ocamlbuild/options.ml +++ b/ocamlbuild/options.ml @@ -238,8 +238,7 @@ let spec = ref ( "-ocamlyacc", set_cmd ocamlyacc, "<command> Set the ocamlyacc tool"; "-menhir", set_cmd ocamlyacc, "<command> Set the menhir tool (use it after -use-menhir)"; "-ocamllex", set_cmd ocamllex, "<command> Set the ocamllex tool"; - (* Not set since we perhaps want to replace ocamlmklib *) - (* "-ocamlmklib", set_cmd ocamlmklib, "<command> Set the ocamlmklib tool"; *) + "-ocamlmklib", set_cmd ocamlmklib, "<command> Set the ocamlmklib tool"; "-ocamlmktop", set_cmd ocamlmktop, "<command> Set the ocamlmktop tool"; "-ocamlrun", set_cmd ocamlrun, "<command> Set the ocamlrun tool"; @@ -316,6 +315,7 @@ let init () = "ocamlopt", ocamlopt; "ocamldep", ocamldep; "ocamldoc", ocamldoc; + "ocamlmklib", ocamlmklib; "ocamlmktop", ocamlmktop; ] end; diff --git a/ocamldoc/.depend b/ocamldoc/.depend index 0f692a22c6..b98bb57fe7 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/odoc_args.ml b/ocamldoc/odoc_args.ml index be5ce12fc6..77b59025b4 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 901febf1ba..9c3efb9824 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 2cf846c301..641d40c0bc 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 4c409a3a17..0ac45ba91a 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] <files>\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 = "<dir>\tAdd <dir> to the list of include directories" -let rectypes = "\tAllow arbitrary recursive types" -let preprocess = "<command>\tPipe sources through preprocessor <command>" -let ppx = "<command>\n\t\tPipe abstract syntax tree through preprocessor <command>" -let option_impl ="<file>\tConsider <file> as a .ml file" -let option_intf ="<file>\tConsider <file> as a .mli file" -let option_text ="<file>\tConsider <file> as a .txt file" -let display_custom_generators_dir = "\tDisplay custom generators standard directory and exit" -let add_load_dir = "<dir>\tAdd the given directory to the search path for custom\n"^ +let option_impl ="<file> Consider <file> as a .ml file" +let option_intf ="<file> Consider <file> as a .mli file" +let option_text ="<file> Consider <file> as a .txt file" +let display_custom_generators_dir = "Display custom generators standard directory and exit" +let add_load_dir = "<dir> Add the given directory to the search path for custom\n"^ "\t\tgenerators" -let load_file = "<file.cm[o|a|xs]>\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 = "<dir>\tGenerate files in directory <dir>, rather than in current\n"^ +let load_file = "<file.cm[o|a|xs]> 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 = "<dir> Generate files in directory <dir>, rather than in current\n"^ "\t\tdirectory (for man and HTML generators)" -let dump = "<file>\tDump collected information into <file>" -let load = "<file>\tLoad information from <file> ; may be used several times" -let css_style = "<file>\n\t\tUse content of <file> 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 = "<file> Dump collected information into <file>" +let load = "<file> Load information from <file> ; may be used several times" +let css_style = "<file> Use content of <file> 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 - "<s>\n\t\tAdd information about character encoding being s\n\t\t(default is %s)" + "<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 = - "<file>\tSet the output file name, used by texi, latex and dot generators\n"^ + "<file> 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 = - "<c1,c2,...,cn>\n\t\tUse colors c1,c1,...,cn in the dot output\n"^ + " <c1,c2,...,cn>\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 = "<section>\n\t\tUse <section> in man page files "^ +let man_section = "<section> Use <section> in man page files "^ "(default is "^default_man_section^") "^man_only^"\n" let default_man_suffix = default_man_section^"o" -let man_suffix = "<suffix>\n\t\tUse <suffix> for man page files "^ +let man_suffix = "<suffix> Use <suffix> for man page files "^ "(default is "^default_man_suffix^") "^man_only^"\n" -let option_title = "<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 a08bf34b43..f24af23b67 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 1c4434f5b3..4b78333364 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 019e2d1c76..d0956a1685 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/location.ml b/parsing/location.ml index c6d1704f15..174377eecb 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 26bbdc1e94..a742d4b7dc 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 5f59dacac3..d078118f89 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 0f6480b826..d7b8ac0bf6 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 22eda40b74..0999edf5f3 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 e9a64528fe..99de0c806e 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 cf8b650e51..0d046378ad 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 ece7c1ea5a..ce6e126db8 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 7fb82dbe29..77b539161f 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 = @@ -1308,6 +1332,7 @@ let format_of_iconvn = function (* 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 '%'; @@ -1326,6 +1351,7 @@ let convert_int64 iconv n = format_int64 (format_of_iconvL iconv) 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 @@ -1435,6 +1461,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 @@ -1474,6 +1504,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 "%_(". *) @@ -1810,26 +1841,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 = @@ -1904,52 +1948,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 @@ -1958,47 +2006,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 @@ -2014,7 +2082,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) -> @@ -2023,8 +2091,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 @@ -2039,28 +2109,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') = @@ -2074,8 +2160,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 @@ -2315,7 +2424,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' | '-' -> ( @@ -2563,24 +2672,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 e51e4e2ce8..f45f434c8f 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 52f428ad83..4e579f3aa9 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 5f1882a2b4..5265a712e6 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 a4ea3aaab3..c2cc6a486a 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 b44fc0a946..541ffbe390 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/lazy.mli b/stdlib/lazy.mli index 6ade2e3d46..f2541b7fd3 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 08b8a4f64b..3395fa86f5 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 d471a4ebb6..6413829146 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 21e28159af..4a72566594 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 2a63ced9a4..1372c41ae8 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 a9be27e138..2da46cd717 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 8f1e178b53..56065bbfbd 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 1cf5d51ede..6f6f997ea4 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/lib-dynlink-native/Makefile b/testsuite/tests/lib-dynlink-native/Makefile index 54126ff59d..f4f9d09942 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 7a6297b6f4..9805d2db42 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 a627b47f40..13c6094bd1 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 387dfb8533..cf2b241ce7 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 dc31633e11..4a74a3fdcb 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 0000000000..a356d52114 --- /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 0000000000..c3e2a7ffd4 --- /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 2922f8e325..cb4ee657b8 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 11ee3a74fd..3a6c3f0dbc 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 8e6a252b86..33054b66e7 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 18fe92baf8..5b2859cb86 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 f95b4803b6..3c1713906c 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 0000000000..cfbcf5c6d3 --- /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 0000000000..c9a08d256b --- /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 0000000000..0547b3d0ee --- /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 0000000000..83502097a9 --- /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 0000000000..58afc787f5 --- /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 0000000000..d4a69fc90e --- /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 5fb9684d47..841a94baa2 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 0000000000..00c2f091d6 --- /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 3eca527145..7580bebe7c 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 e6611acbb2..db35fa5e86 100644 --- a/testsuite/tests/typing-modules/aliases.ml.reference +++ b/testsuite/tests/typing-modules/aliases.ml.reference @@ -382,4 +382,9 @@ module K : sig module E = B module N = E.O end module Q = M end # module R' : S +# 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 5616090606..a9812f4fad 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 657a52145f..53309ad383 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 b0407009d2..c33f5c6f22 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/toplevel/topdirs.ml b/toplevel/topdirs.ml index 1e260139e7..5f347a77de 100644 --- a/toplevel/topdirs.ml +++ b/toplevel/topdirs.ml @@ -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/typing/includemod.ml b/typing/includemod.ml index 3eb26fbd6b..22628496c6 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,38 +364,40 @@ 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 p1 = Pident id1 in let cc = modtypes env (Module id1::cxt) subst (Mtype.strengthen (Env.add_functor_arg id1 env) mty1.md_type p1) 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 @@ -545,7 +548,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 | [] -> @@ -556,11 +559,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 3c3b4b8c7d..873ba3a23a 100644 --- a/typing/mtype.ml +++ b/typing/mtype.ml @@ -361,7 +361,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 1729797454..20b6e5b652 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 9395b52955..2435493402 100644 --- a/typing/typecore.ml +++ b/typing/typecore.ml @@ -2947,6 +2947,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" [] @@ -3012,6 +3014,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/misc.ml b/utils/misc.ml index 898880cb07..2eb8088e77 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 4a3c84b2d9..5168a6a913 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 |