Ekdohibs
/
ocaml
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

merge branch 4.02 from release 4.02.0 to release 4.02.1 

git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@15558 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02
master
Damien Doligez 2014-10-15 13:34:58 +00:00
parent e3ad818fb5 6ca707d066
commit 031cffd155
82 changed files with 1143 additions and 507 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

28
.depend
View File

@ -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 \

68
Changes
View File

@ -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

7
Makefile
View File

@ -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

2
VERSION
View File

@ -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

30
asmrun/signals_osdep.h
View File

@ -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)

1
bytecomp/bytegen.ml
View File

@ -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 ->

3
bytecomp/bytepackager.ml
View File

@ -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

1
bytecomp/emitcode.ml
View File

@ -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

9
bytecomp/lambda.ml
View File

@ -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

8
bytecomp/translcore.ml
View File

@ -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]) ->

59
bytecomp/translmod.ml
View File

@ -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

1
config/s-nt.h
View File

@ -30,3 +30,4 @@
#define HAS_LOCALE
#define HAS_BROKEN_PRINTF
#define HAS_IPV6
#define HAS_NICE

4
config/s-templ.h
View File

@ -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(). */

29
configure vendored
View File

@ -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

8
debugger/source.ml
View File

@ -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 ***)

55
driver/main_args.ml
View File

@ -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;;

20
driver/main_args.mli
View File

@ -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;;

4
emacs/caml-types.el
View File

@ -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.

2
ocamlbuild/ocaml_specific.ml
View File

@ -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");;

4
ocamlbuild/options.ml
View File

@ -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;

18
ocamldoc/.depend
View File

@ -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 \

99
ocamldoc/odoc_args.ml
View File

@ -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

11
ocamldoc/odoc_global.ml
View File

@ -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

7
ocamldoc/odoc_global.mli
View File

@ -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

144
ocamldoc/odoc_messages.ml
View File

@ -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 *)

6
otherlibs/systhreads/Makefile
View File

@ -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,

30
otherlibs/threads/Makefile
View File

@ -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

4
otherlibs/unix/nice.c
View File

@ -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);
}

11
parsing/location.ml
View File

@ -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

4
parsing/parser.mly
View File

@ -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] }

2
parsing/pprintast.ml
View File

@ -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

18
stdlib/arg.ml
View File

@ -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
;;

7
stdlib/arg.mli
View File

@ -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

4
stdlib/array.mli
View File

@ -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

4
stdlib/arrayLabels.mli
View File

@ -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}. *)

29
stdlib/bytes.ml
View File

@ -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

271
stdlib/camlinternalFormat.ml
View File

@ -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
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;
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
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 =

7
stdlib/camlinternalFormatBasics.ml
View File

@ -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)

7
stdlib/camlinternalFormatBasics.mli
View File

@ -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

3
stdlib/camlinternalMod.ml
View File

@ -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 *)

3
stdlib/filename.mli
View File

@ -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.

10
stdlib/format.mli
View File

@ -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].
*)

9
stdlib/lazy.mli
View File

@ -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]. *)

9
stdlib/obj.mli
View File

@ -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."]

4
stdlib/pervasives.mli
View File

@ -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} *)

4
stdlib/printf.mli
View File

@ -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,

5
stdlib/scanf.ml
View File

@ -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);

6
stdlib/sort.mli
View File

@ -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

8
stdlib/string.mli
View File

@ -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].

14
stdlib/stringLabels.mli
View File

@ -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

2
testsuite/tests/lib-dynlink-native/Makefile
View File

@ -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 \

7
testsuite/tests/lib-format/Makefile
View File

@ -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

32
testsuite/tests/lib-format/tformat.ml
View File

@ -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;

98
testsuite/tests/lib-format/tformat.reference
View File

@ -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
Lo positive
256 257 258 259 260 261 262 263 264
Lo negative
265
a
266
t
267
{...%}
268
(...%)
269
Lo positive
270 271 272 273 274 275 276 277 278
Lo negative
279
a
280
t
281
{...%}
282
(...%)
283
! % @ , and constants
270 271 272 273 274 275 276
284 285 286 287 288 289 290
end of tests
All tests succeeded.

9
testsuite/tests/lib-printf/Makefile
View File

@ -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

19
testsuite/tests/lib-printf/pr6534.ml Normal file
View File

@ -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";
()

14
testsuite/tests/lib-printf/pr6534.reference Normal file
View File

@ -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.

29
testsuite/tests/lib-printf/tprintf.ml
View File

@ -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");

96
testsuite/tests/lib-printf/tprintf.reference
View File

@ -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
LX positive
171 172 173 174 175 176
Lx negative
177
Lo positive
178 179 180 181 182 183
Lo negative
184
a
185
LX positive
186 187 188 189 190 191
Lx negative
192
Lo positive
193 194 195 196 197 198
Lo negative
199
a
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.

14
testsuite/tests/lib-scanf/tscanf.ml
View File

@ -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 ());

2
testsuite/tests/lib-scanf/tscanf.reference
View File

@ -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.

2
testsuite/tests/tool-debugger/basic/Makefile
View File

@ -10,7 +10,7 @@
# #
#########################################################################
BASEDIR=../..
BASEDIR=../../..
MAIN_MODULE=debuggee
ADD_COMPFLAGS=-g -custom
LD_PATH=$(TOPDIR)/otherlibs/$(UNIXLIBVAR)unix

4
testsuite/tests/tool-debugger/no_debug_event/.ignore Normal file
View File

@ -0,0 +1,4 @@
compiler-libs
out
c
c.exe

57
testsuite/tests/tool-debugger/no_debug_event/Makefile Normal file
View File

@ -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

1
testsuite/tests/tool-debugger/no_debug_event/a.ml Normal file
View File

@ -0,0 +1 @@
let x = 1

3
testsuite/tests/tool-debugger/no_debug_event/b.ml Normal file
View File

@ -0,0 +1,3 @@
let () =
print_int Foo.A.x;
print_newline ()

2
testsuite/tests/tool-debugger/no_debug_event/input_script Normal file
View File

@ -0,0 +1,2 @@
run
quit

4
testsuite/tests/tool-debugger/no_debug_event/noev.reference Normal file
View File

@ -0,0 +1,4 @@
(ocd) Loading program... done.
1
Program exit.

4
testsuite/tests/typing-extensions/open_types.ml.reference
View File

@ -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>

19
testsuite/tests/typing-modules-bugs/pr6572_ok.ml Normal file
View File

@ -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

9
testsuite/tests/typing-modules/aliases.ml
View File

@ -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;;

5
testsuite/tests/typing-modules/aliases.ml.reference
View File

@ -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
#

6
testsuite/tests/typing-short-paths/short-paths.ml
View File

@ -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;;

11
testsuite/tests/typing-short-paths/short-paths.ml.reference
View File

@ -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
#

12
tools/.depend
View File

@ -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 :

2
toplevel/topdirs.ml
View File

@ -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 ->

48
typing/includemod.ml
View File

@ -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 ->

4
typing/mtype.ml
View File

@ -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

12
typing/parmatch.ml
View File

@ -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

4
typing/typecore.ml
View File

@ -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 ->

16
utils/misc.ml
View File

@ -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

2
utils/misc.mli
View File

@ -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