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 \
driver/compenv.cmx utils/clflags.cmx asmcomp/asmpackager.cmx \
asmcomp/asmlink.cmx asmcomp/asmlibrarian.cmx asmcomp/arch.cmx \
driver/optmain.cmi
-driver/pparse.cmo : parsing/parsetree.cmi parsing/parse.cmi utils/misc.cmi \
- parsing/location.cmi utils/config.cmi utils/clflags.cmi utils/ccomp.cmi \
- parsing/ast_mapper.cmi parsing/ast_helper.cmi driver/pparse.cmi
-driver/pparse.cmx : parsing/parsetree.cmi parsing/parse.cmx utils/misc.cmx \
- parsing/location.cmx utils/config.cmx utils/clflags.cmx utils/ccomp.cmx \
- parsing/ast_mapper.cmx parsing/ast_helper.cmx driver/pparse.cmi
+driver/pparse.cmo : parsing/parse.cmi utils/misc.cmi parsing/location.cmi \
+ utils/config.cmi utils/clflags.cmi utils/ccomp.cmi parsing/ast_mapper.cmi \
+ driver/pparse.cmi
+driver/pparse.cmx : parsing/parse.cmx utils/misc.cmx parsing/location.cmx \
+ utils/config.cmx utils/clflags.cmx utils/ccomp.cmx parsing/ast_mapper.cmx \
+ driver/pparse.cmi
toplevel/genprintval.cmi : typing/types.cmi typing/path.cmi \
typing/outcometree.cmi typing/env.cmi
toplevel/opttopdirs.cmi : parsing/longident.cmi
/ocamldoc/odoc_text_parser.ml
/ocamldoc/odoc_text_parser.mli
/ocamldoc/stdlib_man
+/ocamldoc/stdlib_html
/ocamldoc/*.output
/ocamldoc/test_stdlib
/ocamldoc/test_latex
+OCaml 4.02.1:
+-------------
+(Changes that can break existing programs are marked with a "*")
+
+Standard library:
+* Add optional argument ?limit to Arg.align.
+
+- PR#4099: Bug in Makefile.nt: won't stop on error
+ (George Necula)
+- PR#6181: Improve MSVC build
+ (Chen Gang)
+- PR#6207: Configure doesn't detect features correctly on Haiku
+ (Jessica Hamilton)
+- PR#6466: Non-exhaustive matching warning message for open types is confusing
+ (Peter Zotov)
+- PR#6529: fix quadratic-time algorithm in Consistbl.extract.
+ (Xavier Leroy, Alain Frisch, relase-worthy report by Jacques-Pascal Deplaix)
+- PR#6530: Add stack overflow handling for native code (OpenBSD i386 and amd64)
+ (Cristopher Zimmermann)
+- PR#6533: broken semantics of %(%) when substitued by a box
+ (Benoît Vaugon, report by Boris Yakobowski)
+- PR#6534: legacy support for %.10s
+ (Benoît Vaugon, Gabriel Scherer, report by Nick Chapman)
+- PR#6536: better documentation of flag # in format strings
+ (Damien Doligez, report by Nick Chapman)
+- PR#6544: Bytes and CamlinternalFormat missing from threads stdlib.cma
+ (Christopher Zimmermann)
+- PR#6546: -dsource omits parens for `List ((`String "A")::[]) in patterns
+ (Gabriel Scherer, report by Peter Zotov)
+- PR#6547: __MODULE__ aborts the compiler if the module name cannot be inferred
+ (Jacques Garrigue, report by Kaustuv Chaudhuri)
+- PR#6549: Debug section is sometimes not readable when using -pack
+ (Hugo Heuzard, review by Gabriel Scherer)
+- PR#6553: Missing command line options for ocamldoc
+ (Maxence Guesdon)
+- PR#6554: fix race condition when retrieving backtraces
+ (Jérémie Dimino, Mark Shinwell).
+- PR#6557: String.sub throws Invalid_argument("Bytes.sub")
+ (Damien Doligez, report by Oliver Bandel)
+- PR#6562: Fix ocamldebug module source lookup
+ (Leo White)
+- PR#6563: Inclusion of packs failing to run module initializers
+ (Jacques Garrigue, report by Mark Shinwell)
+- PR#6564: infinite loop in Mtype.remove_aliases
+ (Jacques Garrigue, report by Mark Shinwell)
+- PR#6565: compilation fails with Env.Error(_)
+ (Jacques Garrigue and Mark Shinwell)
+- PR#6566: -short-paths and signature inclusion errors
+ (Jacques Garrigue, report by Mark Shinwell)
+- PR#6572: Fatal error with recursive modules
+ (Jacques Garrigue, report by Quentin Stievenart)
+- PR#6578: Recursive module containing alias causes Segmentation fault
+ (Jacques Garrigue)
+- PR#6581: Some bugs in generative functors
+ (Jacques Garrigue, report by Mark Shinwell)
+- PR#6584: ocamldep support for "-open M"
+ (Gabriel Scherer, review by Damien Doligez, report by Hezekiah M. Carty)
+- PR#6588: Code generation errors for ARM
+ (Mark Shinwell, Xavier Leroy)
+- PR#6590: Improve Windows (MSVC and mingw) build
+ (Chen Gang)
+- PR#6599: ocamlbuild: add -bin-annot when using -pack
+ (Christopher Zimmermann)
+- PR#6602: Fatal error when tracing a function with abstract type
+ (Jacques Garrigue, report by Hugo Herbelin)
+- ocamlbuild: add an -ocamlmklib option to change the ocamlmklib command
+ (Jérôme Vouillon)
+
OCaml 4.02.0:
-------------
- 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
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
cp expunge $(INSTALL_LIBDIR)/expunge.exe
cp toplevel/topdirs.cmi $(INSTALL_LIBDIR)
cd tools ; $(MAKEREC) install
- for i in $(OTHERLIBRARIES); do $(MAKEREC) -C otherlibs/$$i install; done
+ for i in $(OTHERLIBRARIES); do \
+ $(MAKEREC) -C otherlibs/$$i install || exit $$?; \
+ done
if test -n "$(WITH_OCAMLDOC)"; then (cd ocamldoc; $(MAKEREC) install); \
else :; fi
if test -n "$(WITH_DEBUGGER)"; then (cd debugger; $(MAKEREC) install); \
-4.02.0
+4.02.1
# The version string is the first line of this file.
# It must be in the format described in stdlib/sys.mli
| l -> (* Parallel move: first copy srcs into tmps one by one,
then copy tmps into dsts one by one *)
let tmps = Reg.createv_like srcs in
- array_fold2 insert_single_move
- (array_fold2 insert_single_move i srcs tmps) tmps dsts
+ let i1 = array_fold2 insert_single_move i tmps dsts in
+ array_fold2 insert_single_move i1 srcs tmps
(* Classification of operations *)
Iextcall(_, _) -> if abi = EABI then 0 else 4
| Ialloc _ -> if abi = EABI then 0 else 7
| Iconst_symbol _ when !pic_code -> 7
+ | Iintop Imulh when !arch < ARMv6 -> 8
| _ -> 9
let max_register_pressure = function
| Iconst_symbol _ when !pic_code -> [| 7; 16; 32 |]
| Iintoffloat | Ifloatofint
| Iload(Single, _) | Istore(Single, _, _) -> [| 9; 15; 31 |]
+ | Iintop Imulh when !arch < ARMv6 -> [| 8; 16; 32 |]
| _ -> [| 9; 16; 32 |]
(* Pure operations (without any side effect besides updating their result
exception Use_default
let r1 = phys_reg 1
+let r6 = phys_reg 6
+let r7 = phys_reg 7
let r12 = phys_reg 8
let pseudoregs_for_operation op arg res =
Iintop Imul | Ispecific Imuladd when !arch < ARMv6 ->
(arg, [| res.(0); arg.(0) |])
(* For smull rdlo,rdhi,rn,rm (pre-ARMv6) the registers rdlo, rdhi and rn
- must be different. We deal with this by pretending that rn is also a
- result of the smull operation. *)
+ must be different. Also, rdlo (whose contents we discard) is always
+ forced to be r12 in proc.ml, which means that neither rdhi and rn can
+ be r12. To keep things simple, we force both of those two to specific
+ hard regs: rdhi in r6 and rn in r7. *)
| Iintop Imulh when !arch < ARMv6 ->
- (arg, [| res.(0); arg.(0) |])
+ ([| r7; arg.(1) |], [| r6 |])
(* Soft-float Iabsf and Inegf: arg.(0) and res.(0) must be the same *)
| Iabsf | Inegf when !fpu = Soft ->
([|res.(0); arg.(1)|], res)
{
CAMLparam0();
CAMLlocal1(res);
+ const int tag = 0;
- res = caml_alloc(caml_backtrace_pos, 0);
- if(caml_backtrace_buffer != NULL) {
+ /* Beware: the allocations below may cause finalizers to be run, and another
+ backtrace---possibly of a different length---to be stashed (for example
+ if the finalizer raises then catches an exception). We choose to ignore
+ any such finalizer backtraces and return the original one. */
+
+ if (caml_backtrace_buffer == NULL || caml_backtrace_pos == 0) {
+ res = caml_alloc(0, tag);
+ }
+ else {
+ code_t saved_caml_backtrace_buffer[BACKTRACE_BUFFER_SIZE];
+ int saved_caml_backtrace_pos;
intnat i;
- for(i = 0; i < caml_backtrace_pos; i++)
- Field(res, i) = Val_Descrptr(caml_backtrace_buffer[i]);
+
+ saved_caml_backtrace_pos = caml_backtrace_pos;
+
+ if (saved_caml_backtrace_pos > BACKTRACE_BUFFER_SIZE) {
+ saved_caml_backtrace_pos = BACKTRACE_BUFFER_SIZE;
+ }
+
+ memcpy(saved_caml_backtrace_buffer, caml_backtrace_buffer,
+ saved_caml_backtrace_pos * sizeof(code_t));
+
+ res = caml_alloc(saved_caml_backtrace_pos, tag);
+ for (i = 0; i < saved_caml_backtrace_pos; i++) {
+ /* [Val_Descrptr] always returns an immediate. */
+ Field(res, i) = Val_Descrptr(saved_caml_backtrace_buffer[i]);
+ }
}
+
CAMLreturn(res);
}
CAMLprim value caml_get_exception_backtrace(value unit)
{
CAMLparam0();
- CAMLlocal4(arr, raw_slot, slot, res);
+ CAMLlocal3(arr, res, backtrace);
+ intnat i;
- arr = caml_alloc(caml_backtrace_pos, 0);
- if (caml_backtrace_buffer == NULL) {
- Assert(caml_backtrace_pos == 0);
- } else {
- intnat i;
- for(i = 0; i < caml_backtrace_pos; i++) {
- raw_slot = Val_Descrptr(caml_backtrace_buffer[i]);
- slot = caml_convert_raw_backtrace_slot(raw_slot);
- caml_modify(&Field(arr, i), slot);
- }
+ backtrace = caml_get_exception_raw_backtrace(Val_unit);
+
+ arr = caml_alloc(Wosize_val(backtrace), 0);
+ for (i = 0; i < Wosize_val(backtrace); i++) {
+ Store_field(arr, i, caml_convert_raw_backtrace_slot(Field(backtrace, i)));
}
+
res = caml_alloc_small(1, 0); Field(res, 0) = arr; /* Some */
CAMLreturn(res);
}
#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)
#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)
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 ->
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
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
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
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 ->
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]) ->
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 ->
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
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
*)
| _ ->
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
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
res = caml_alloc_tuple (7);
Store_field (res, 0, Val_long (Wsize_bsize (caml_minor_heap_size))); /* s */
- Store_field (res, 1,Val_long(Wsize_bsize(caml_major_heap_increment)));/* i */
+ Store_field (res, 1, Val_long (caml_major_heap_increment)); /* i */
Store_field (res, 2, Val_long (caml_percent_free)); /* o */
Store_field (res, 3, Val_long (caml_verb_gc)); /* v */
Store_field (res, 4, Val_long (caml_percent_max)); /* O */
### Flexlink
FLEXLINK=flexlink -chain mingw -stack 16777216 -link -static-libgcc
-FLEXDIR=$(shell $(FLEXLINK) -where)
+FLEXDIR:=$(shell $(FLEXLINK) -where)
IFLEXDIR=-I"$(FLEXDIR)"
MKDLL=$(FLEXLINK)
MKEXE=$(FLEXLINK) -exe
### Flexlink
FLEXLINK=flexlink -chain mingw64 -stack 33554432
-FLEXDIR=$(shell $(FLEXLINK) -where)
+FLEXDIR:=$(shell $(FLEXLINK) -where)
IFLEXDIR=-I"$(FLEXDIR)"
MKDLL=$(FLEXLINK)
MKEXE=$(FLEXLINK) -exe
SHAREDCCCOMPOPTS=
NATIVECCPROFOPTS=
NATIVECCRPATH=
-ASM=ml /nologo /coff /Cp /c /Fo
+ASM=ml -nologo -coff -Cp -c -Fo
ASPP=
ASPPPROFFLAGS=
PROFILING=noprof
########## Configuration for the bytecode compiler
### Which C compiler to use for the bytecode interpreter.
-BYTECC=cl /nologo -D_CRT_SECURE_NO_DEPRECATE
+BYTECC=cl -nologo -D_CRT_SECURE_NO_DEPRECATE
### Additional compile-time options for $(BYTECC). (For static linking.)
-BYTECCCOMPOPTS=/Ox /MD
+BYTECCCOMPOPTS=-Ox -MD
### Additional link-time options for $(BYTECC). (For static linking.)
BYTECCLINKOPTS=
### Additional compile-time options for $(BYTECC). (For building a DLL.)
-DLLCCCOMPOPTS=/Ox /MD
+DLLCCCOMPOPTS=-Ox -MD
### Libraries needed
BYTECCLIBS=advapi32.lib ws2_32.lib
NATIVECCLIBS=advapi32.lib ws2_32.lib
### How to invoke the C preprocessor
-CPP=cl /nologo /EP
+CPP=cl -nologo -EP
### Flexlink
FLEXLINK=flexlink -merge-manifest -stack 16777216
-FLEXDIR=$(shell $(FLEXLINK) -where)
+FLEXDIR:=$(shell $(FLEXLINK) -where)
IFLEXDIR=-I"$(FLEXDIR)"
MKDLL=$(FLEXLINK)
MKEXE=$(FLEXLINK) -exe
MKMAINDLL=$(FLEXLINK) -maindll
### How to build a static library
-MKLIB=link /lib /nologo /out:$(1) $(2)
-#ml let mklib out files opts = Printf.sprintf "link /lib /nologo /out:%s %s %s" out opts files;;
+MKLIB=link -lib -nologo -out:$(1) $(2)
+#ml let mklib out files opts = Printf.sprintf "link -lib -nologo -out:%s %s %s" out opts files;;
MKSHAREDLIBRPATH=
### Canonicalize the name of a system library
SYSTEM=win32
### Which C compiler to use for the native-code compiler.
-NATIVECC=cl /nologo -D_CRT_SECURE_NO_DEPRECATE
+NATIVECC=cl -nologo -D_CRT_SECURE_NO_DEPRECATE
### Additional compile-time options for $(NATIVECC).
-NATIVECCCOMPOPTS=/Ox /MD
+NATIVECCCOMPOPTS=-Ox -MD
### Additional link-time options for $(NATIVECC)
NATIVECCLINKOPTS=
### Build partially-linked object file
-PACKLD=link /lib /nologo /out:# there must be no space after this '/out:'
+PACKLD=link -lib -nologo -out:# there must be no space after this '-out:'
### Clear this to disable compiling ocamldebug
WITH_DEBUGGER=ocamldebugger
SHAREDCCCOMPOPTS=
NATIVECCPROFOPTS=
NATIVECCRPATH=
-ASM=ml64 /nologo /Cp /c /Fo
+ASM=ml64 -nologo -Cp -c -Fo
ASPP=
ASPPPROFFLAGS=
PROFILING=noprof
########## Configuration for the bytecode compiler
### Which C compiler to use for the bytecode interpreter.
-BYTECC=cl /nologo -D_CRT_SECURE_NO_DEPRECATE
+BYTECC=cl -nologo -D_CRT_SECURE_NO_DEPRECATE
### Additional compile-time options for $(BYTECC). (For static linking.)
-BYTECCCOMPOPTS=/Ox /MD
+BYTECCCOMPOPTS=-Ox -MD
### Additional compile-time options for $(BYTECC). (For debug version.)
-BYTECCDBGCOMPOPTS=-DDEBUG /Zi /W3 /Wp64
+BYTECCDBGCOMPOPTS=-DDEBUG -Zi -W3 -Wp64
### Additional link-time options for $(BYTECC). (For static linking.)
BYTECCLINKOPTS=
### Additional compile-time options for $(BYTECC). (For building a DLL.)
-DLLCCCOMPOPTS=/Ox /MD
+DLLCCCOMPOPTS=-Ox -MD
### Libraries needed
#EXTRALIBS=bufferoverflowu.lib # for the old PSDK compiler only
NATIVECCLIBS=advapi32.lib ws2_32.lib $(EXTRALIBS)
### How to invoke the C preprocessor
-CPP=cl /nologo /EP
+CPP=cl -nologo -EP
### Flexlink
FLEXLINK=flexlink -x64 -merge-manifest -stack 33554432
-FLEXDIR=$(shell $(FLEXLINK) -where)
+FLEXDIR:=$(shell $(FLEXLINK) -where)
IFLEXDIR=-I"$(FLEXDIR)"
MKDLL=$(FLEXLINK)
MKEXE=$(FLEXLINK) -exe
MKMAINDLL=$(FLEXLINK) -maindll
### How to build a static library
-MKLIB=link /lib /nologo /machine:AMD64 /out:$(1) $(2)
-#ml let mklib out files opts = Printf.sprintf "link /lib /nologo /machine:AMD64 /out:%s %s %s" out opts files;;
+MKLIB=link -lib -nologo -machine:AMD64 /out:$(1) $(2)
+#ml let mklib out files opts = Printf.sprintf "link -lib -nologo -machine:AMD64 -out:%s %s %s" out opts files;;
MKSHAREDLIBRPATH=
### Canonicalize the name of a system library
SYSTEM=win64
### Which C compiler to use for the native-code compiler.
-NATIVECC=cl /nologo
+NATIVECC=cl -nologo
### Additional compile-time options for $(NATIVECC).
-NATIVECCCOMPOPTS=/Ox /MD
+NATIVECCCOMPOPTS=-Ox -MD
### Additional link-time options for $(NATIVECC)
NATIVECCLINKOPTS=
### Build partially-linked object file
-PACKLD=link /lib /nologo /machine:AMD64 /out:# must have no space after '/out:'
+PACKLD=link -lib -nologo -machine:AMD64 -out:# must have no space after '-out:'
### Clear this to disable compiling ocamldebug
WITH_DEBUGGER=ocamldebugger
#define HAS_LOCALE
#define HAS_BROKEN_PRINTF
#define HAS_IPV6
+#define HAS_NICE
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(). */
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
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"
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;;
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
asppprofflags='-DPROFILING'
case "$arch,$system" in
- amd64,macosx) if ./searchpath clang; then
+ amd64,macosx) if sh ./searchpath clang; then
as='clang -arch x86_64 -c'
aspp='clang -arch x86_64 -c'
else
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*)
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
# 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;;
*)
pthread_caml_link="-cclib -pthread";;
*-*-openbsd*) pthread_link="-pthread"
pthread_caml_link="-cclib -pthread";;
+ *-*-haiku*) pthread_link=""
+ pthread_caml_link="";;
*) pthread_link="-lpthread"
pthread_caml_link="-cclib -lpthread";;
esac
- if ./hasgot -i pthread.h $pthread_link pthread_self; then
+ if sh ./hasgot -i pthread.h $pthread_link pthread_self; then
inf "POSIX threads library supported."
systhread_support=true
otherlibraries="$otherlibraries systhreads"
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
if test "$x11_include" = "-I/usr/include"; then
x11_include=""
fi
- if ./hasgot $x11_include $x11_link -i X11/Xlib.h XrmInitialize; then
+ if sh ./hasgot $x11_include $x11_link -i X11/Xlib.h XrmInitialize; then
inf "X11 works"
else
wrn "Cannot compile X11 program."
# Look for BFD library
-if ./hasgot -i bfd.h && \
- ./hasgot -lbfd -ldl -liberty -lz bfd_openr; then
+if sh ./hasgot -DPACKAGE=ocaml -i bfd.h && \
+ sh ./hasgot -DPACKAGE=ocaml -lbfd -ldl -liberty -lz bfd_openr; then
inf "BFD library found."
echo "#define HAS_LIBBFD" >> s.h
echo "LIBBFD_LINK=-lbfd -ldl -liberty -lz" >> Makefile
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 ***)
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
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;;
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;;
(* *)
(***********************************************************************)
+(* 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
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;;
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;;
None -> ()
| Some _ -> Misc.remove_file inputfile
+
+(* Note: some of the functions here should go to Ast_mapper instead,
+ which would encapsulate the "binary AST" protocol. *)
+
let write_ast magic ast =
let fn = Filename.temp_file "camlppx" "" in
let oc = open_out_bin fn in
Misc.remove_file fn;
raise exn
-let apply_rewriters ~tool_name magic ast =
- let ctx = Ast_mapper.ppx_context ~tool_name () in
+let rewrite magic ast ppxs =
+ read_ast magic
+ (List.fold_left (apply_rewriter magic) (write_ast magic ast)
+ (List.rev ppxs))
+
+let apply_rewriters_str ?(restore = true) ~tool_name ast =
match !Clflags.all_ppx with
| [] -> ast
| ppxs ->
- let ast =
- if magic = Config.ast_impl_magic_number
- then Obj.magic (Ast_helper.Str.attribute ctx :: (Obj.magic ast))
- else Obj.magic (Ast_helper.Sig.attribute ctx :: (Obj.magic ast))
- in
- let fn =
- List.fold_left (apply_rewriter magic) (write_ast magic ast)
- (List.rev ppxs)
- in
- let ast = read_ast magic fn in
- let open Parsetree in
- if magic = Config.ast_impl_magic_number then
- let ast =
- match Obj.magic ast with
- | {pstr_desc = Pstr_attribute({Location.txt = "ocaml.ppx.context"}, _)}
- :: items ->
- items
- | items -> items
- in
- Obj.magic ast
- else
- let ast =
- match Obj.magic ast with
- | {psig_desc = Psig_attribute({Location.txt = "ocaml.ppx.context"}, _)}
- :: items ->
- items
- | items -> items
- in
- Obj.magic ast
+ let ast = Ast_mapper.add_ppx_context_str ~tool_name ast in
+ let ast = rewrite Config.ast_impl_magic_number ast ppxs in
+ Ast_mapper.drop_ppx_context_str ~restore ast
+let apply_rewriters_sig ?(restore = true) ~tool_name ast =
+ match !Clflags.all_ppx with
+ | [] -> ast
+ | ppxs ->
+ let ast = Ast_mapper.add_ppx_context_sig ~tool_name ast in
+ let ast = rewrite Config.ast_intf_magic_number ast ppxs in
+ Ast_mapper.drop_ppx_context_sig ~restore ast
+
+let apply_rewriters ?restore ~tool_name magic ast =
+ if magic = Config.ast_impl_magic_number then
+ Obj.magic (apply_rewriters_str ?restore ~tool_name (Obj.magic ast))
+ else if magic = Config.ast_intf_magic_number then
+ Obj.magic (apply_rewriters_sig ?restore ~tool_name (Obj.magic ast))
+ else
+ assert false
(* Parse a file or get a dumped syntax tree from it *)
with x -> close_in ic; raise x
in
close_in ic;
- apply_rewriters ~tool_name ast_magic ast
+ apply_rewriters ~restore:false ~tool_name ast_magic ast
let report_error ppf = function
| CannotRun cmd ->
val preprocess : string -> string
val remove_preprocessed : string -> unit
val file : formatter -> tool_name:string -> string -> (Lexing.lexbuf -> 'a) -> string -> 'a
-val apply_rewriters : tool_name:string -> string -> 'a -> 'a
+val apply_rewriters: ?restore:bool -> tool_name:string -> string -> 'a -> 'a
+ (** If [restore = true] (the default), cookies set by external rewriters will be
+ kept for later calls. *)
+
+val apply_rewriters_str: ?restore:bool -> tool_name:string -> Parsetree.structure -> Parsetree.structure
+val apply_rewriters_sig: ?restore:bool -> tool_name:string -> Parsetree.signature -> Parsetree.signature
+
+
val report_error : formatter -> error -> unit
(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.
.BI \-ppx \ command
After parsing, pipe the abstract syntax tree through the preprocessor
.IR command .
-The format of the input and output of the preprocessor
-are not yet documented.
+The module
+.BR Ast_mapper (3)
+implements the external interface of a preprocessor.
.TP
.B \-principal
Check information path during type-checking, to make sure that all
.BI \-ppx \ command
After parsing, pipe the abstract syntax tree through the preprocessor
.IR command .
-The format of the input and output of the preprocessor
-are not yet documented.
+The module
+.BR Ast_mapper (3)
+implements the external interface of a preprocessor.
.TP
.B \-principal
Check information path during type-checking, to make sure that all
.BI \-ppx \ command
After parsing, pipe the abstract syntax tree through the preprocessor
.IR command .
-The format of the input and output of the preprocessor
-are not yet documented.
+The module
+.BR Ast_mapper (3)
+implements the external interface of a preprocessor.
.TP
.B \-principal
Check information path during type-checking, to make sure that all
(fun param -> S [A "-w"; A param]);
pflag ["ocaml";"compile";] "warn_error"
(fun param -> S [A "-warn-error"; A param]);
+ pflag ["ocaml"; "ocamldep"] "open"
+ (fun param -> S [A "-open"; A param]);
pflag ["ocaml"; "compile"] "open"
(fun param -> S [A "-open"; A param]);
()
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");;
"-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";
"ocamlopt", ocamlopt;
"ocamldep", ocamldep;
"ocamldoc", ocamldoc;
+ "ocamlmklib", ocamlmklib;
"ocamlmktop", ocamlmktop;
]
end;
~matching:[M.f "test.byte"]
~targets:("test.byte",[]) ();;
+let () = test "OpenDependencies"
+ ~description:"Test dependency computation for the new -open feature (PR#6584)"
+ ~options:[`no_ocamlfind]
+ ~tree:[
+ T.f "a.ml" ~content:"let x = 1";
+ T.f "b.ml" ~content:"print_int x; print_newline ()";
+ T.f "_tags" ~content: "<b.*>: open(A)";
+ ]
+ ~matching:[M.f "b.byte"]
+ ~targets:("b.byte",[]) ();;
+
run ~root:"_test_internal";;
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 \
STDLIB_MLIS=../stdlib/*.mli \
+ ../parsing/*.mli \
../otherlibs/$(UNIXLIB)/unix.mli \
../otherlibs/str/str.mli \
../otherlibs/bigarray/bigarray.mli \
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 ;
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
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
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
(** 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
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)"
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" ] ;
]
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"
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")
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 =
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 ;
merge_all ]
)
-let help = "\t\tDisplay this list of options"
+let help = " Display this list of options"
(** Error and warning messages *)
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) \
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,
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
{
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);
}
open Asttypes
-open Longident
open Parsetree
open Ast_helper
open Location
{ loc; txt = "ocaml.ppwarning" },
PStr ([Str.eval ~loc (Exp.constant (Const_string (s, None)))])
+module StringMap = Map.Make(struct
+ type t = string
+ let compare = compare
+end)
+
+let cookies = ref StringMap.empty
+
+let get_cookie k =
+ try Some (StringMap.find k !cookies)
+ with Not_found -> None
+
+let set_cookie k v =
+ cookies := StringMap.add k v !cookies
+
let tool_name_ref = ref "_none_"
let tool_name () = !tool_name_ref
-let restore_ppx_context payload =
- let fields =
- match payload with
+
+module PpxContext = struct
+ open Longident
+ open Asttypes
+ open Ast_helper
+
+ let lid name = { txt = Lident name; loc = Location.none }
+
+ let make_string x = Exp.constant (Const_string (x, None))
+
+ let make_bool x =
+ if x
+ then Exp.construct (lid "true") None
+ else Exp.construct (lid "false") None
+
+ let rec make_list f lst =
+ match lst with
+ | x :: rest ->
+ Exp.construct (lid "::") (Some (Exp.tuple [f x; make_list f rest]))
+ | [] ->
+ Exp.construct (lid "[]") None
+
+ let make_pair f1 f2 (x1, x2) =
+ Exp.tuple [f1 x1; f2 x2]
+
+ let make_option f opt =
+ match opt with
+ | Some x -> Exp.construct (lid "Some") (Some (f x))
+ | None -> Exp.construct (lid "None") None
+
+ let get_cookies () =
+ lid "cookies",
+ make_list (make_pair make_string (fun x -> x))
+ (StringMap.bindings !cookies)
+
+ let mk fields =
+ { txt = "ocaml.ppx.context"; loc = Location.none },
+ Parsetree.PStr [Str.eval (Exp.record fields None)]
+
+ let make ~tool_name () =
+ let fields =
+ [
+ lid "tool_name", make_string tool_name;
+ lid "include_dirs", make_list make_string !Clflags.include_dirs;
+ lid "load_path", make_list make_string !Config.load_path;
+ lid "open_modules", make_list make_string !Clflags.open_modules;
+ lid "for_package", make_option make_string !Clflags.for_package;
+ lid "debug", make_bool !Clflags.debug;
+ get_cookies ()
+ ]
+ in
+ mk fields
+
+ let get_fields = function
| PStr [{pstr_desc = Pstr_eval
({ pexp_desc = Pexp_record (fields, None) }, [])}] ->
fields
| _ ->
raise_errorf "Internal error: invalid [@@@ocaml.ppx.context] syntax"
- in
- let field name payload =
- let rec get_string = function
- | { pexp_desc = Pexp_constant (Const_string (str, None)) } -> str
- | _ ->
- raise_errorf
- "Internal error: invalid [@@@ocaml.ppx.context { %s }] string syntax"
- name
- and get_bool pexp =
- match pexp with
- | {pexp_desc = Pexp_construct ({txt = Longident.Lident "true"}, None)} ->
- true
- | {pexp_desc = Pexp_construct ({txt = Longident.Lident "false"}, None)} ->
- false
- | _ ->
- raise_errorf
- "Internal error: invalid [@@@ocaml.ppx.context { %s }] bool syntax"
- name
- and get_list elem = function
- | {pexp_desc =
- Pexp_construct ({txt = Longident.Lident "::"},
- Some {pexp_desc = Pexp_tuple [exp; rest]}) } ->
- elem exp :: get_list elem rest
- | {pexp_desc =
- Pexp_construct ({txt = Longident.Lident "[]"}, None)} ->
- []
- | _ ->
- raise_errorf
- "Internal error: invalid [@@@ocaml.ppx.context { %s }] list syntax"
- name
- and get_option elem = function
- | { pexp_desc =
- Pexp_construct ({ txt = Longident.Lident "Some" }, Some exp) } ->
- Some (elem exp)
- | { pexp_desc =
- Pexp_construct ({ txt = Longident.Lident "None" }, None) } ->
- None
+
+ let restore fields =
+ let field name payload =
+ let rec get_string = function
+ | { pexp_desc = Pexp_constant (Const_string (str, None)) } -> str
+ | _ ->
+ raise_errorf
+ "Internal error: invalid [@@@ocaml.ppx.context { %s }] string syntax"
+ name
+ and get_bool pexp =
+ match pexp with
+ | {pexp_desc = Pexp_construct ({txt = Longident.Lident "true"}, None)} ->
+ true
+ | {pexp_desc = Pexp_construct ({txt = Longident.Lident "false"}, None)} ->
+ false
+ | _ ->
+ raise_errorf
+ "Internal error: invalid [@@@ocaml.ppx.context { %s }] bool syntax"
+ name
+ and get_list elem = function
+ | {pexp_desc =
+ Pexp_construct ({txt = Longident.Lident "::"},
+ Some {pexp_desc = Pexp_tuple [exp; rest]}) } ->
+ elem exp :: get_list elem rest
+ | {pexp_desc =
+ Pexp_construct ({txt = Longident.Lident "[]"}, None)} ->
+ []
+ | _ ->
+ raise_errorf
+ "Internal error: invalid [@@@ocaml.ppx.context { %s }] list syntax"
+ name
+ and get_pair f1 f2 = function
+ | {pexp_desc = Pexp_tuple [e1; e2]} ->
+ (f1 e1, f2 e2)
+ | _ ->
+ raise_errorf
+ "Internal error: invalid [@@@ocaml.ppx.context { %s }] pair syntax"
+ name
+ and get_option elem = function
+ | { pexp_desc =
+ Pexp_construct ({ txt = Longident.Lident "Some" }, Some exp) } ->
+ Some (elem exp)
+ | { pexp_desc =
+ Pexp_construct ({ txt = Longident.Lident "None" }, None) } ->
+ None
+ | _ ->
+ raise_errorf
+ "Internal error: invalid [@@@ocaml.ppx.context { %s }] option syntax"
+ name
+ in
+ match name with
+ | "tool_name" ->
+ tool_name_ref := get_string payload
+ | "include_dirs" ->
+ Clflags.include_dirs := get_list get_string payload
+ | "load_path" ->
+ Config.load_path := get_list get_string payload
+ | "open_modules" ->
+ Clflags.open_modules := get_list get_string payload
+ | "for_package" ->
+ Clflags.for_package := get_option get_string payload
+ | "debug" ->
+ Clflags.debug := get_bool payload
+ | "cookies" ->
+ let l = get_list (get_pair get_string (fun x -> x)) payload in
+ cookies :=
+ List.fold_left
+ (fun s (k, v) -> StringMap.add k v s) StringMap.empty
+ l
| _ ->
- raise_errorf
- "Internal error: invalid [@@@ocaml.ppx.context { %s }] option syntax"
- name
+ ()
in
- match name with
- | "tool_name" ->
- tool_name_ref := get_string payload
- | "include_dirs" ->
- Clflags.include_dirs := get_list get_string payload
- | "load_path" ->
- Config.load_path := get_list get_string payload
- | "open_modules" ->
- Clflags.open_modules := get_list get_string payload
- | "for_package" ->
- Clflags.for_package := get_option get_string payload
- | "debug" ->
- Clflags.debug := get_bool payload
- | _ ->
- ()
- in
- List.iter (function ({txt=Lident name}, x) -> field name x | _ -> ()) fields
+ List.iter (function ({txt=Lident name}, x) -> field name x | _ -> ()) fields
-let apply ~source ~target mapper =
+ let update_cookies fields =
+ let fields =
+ List.filter
+ (function ({txt=Lident "cookies"}, _) -> false | _ -> true)
+ fields
+ in
+ fields @ [get_cookies ()]
+end
+
+let ppx_context = PpxContext.make
+
+
+let apply_lazy ~source ~target mapper =
let ic = open_in_bin source in
let magic =
really_input_string ic (String.length Config.ast_impl_magic_number)
let implem ast =
try
- begin match ast with
- | {pstr_desc = Pstr_attribute ({txt = "ocaml.ppx.context"}, x)} :: _ ->
- restore_ppx_context x
- | _ -> ()
- end;
- mapper.structure mapper ast
+ let fields, ast =
+ match ast with
+ | {pstr_desc = Pstr_attribute ({txt = "ocaml.ppx.context"}, x)} :: l ->
+ PpxContext.get_fields x, l
+ | _ -> [], ast
+ in
+ PpxContext.restore fields;
+ let mapper = mapper () in
+ let ast = mapper.structure mapper ast in
+ let fields = PpxContext.update_cookies fields in
+ Str.attribute (PpxContext.mk fields) :: ast
with exn ->
match error_of_exn exn with
| Some error ->
in
let iface ast =
try
- begin match ast with
- | {psig_desc = Psig_attribute ({txt = "ocaml.ppx.context"}, x)} :: _ ->
- restore_ppx_context x
- | _ -> ()
- end;
- mapper.signature mapper ast
+ let fields, ast =
+ match ast with
+ | {psig_desc = Psig_attribute ({txt = "ocaml.ppx.context"}, x)} :: l ->
+ PpxContext.get_fields x, l
+ | _ -> [], ast
+ in
+ PpxContext.restore fields;
+ let mapper = mapper () in
+ let ast = mapper.signature mapper ast in
+ let fields = PpxContext.update_cookies fields in
+ Sig.attribute (PpxContext.mk fields) :: ast
with exn ->
match error_of_exn exn with
| Some error ->
output_value oc ast;
close_out oc
+let drop_ppx_context_str ~restore = function
+ | {pstr_desc = Pstr_attribute({Location.txt = "ocaml.ppx.context"}, a)}
+ :: items ->
+ if restore then
+ PpxContext.restore (PpxContext.get_fields a);
+ items
+ | items -> items
+
+let drop_ppx_context_sig ~restore = function
+ | {psig_desc = Psig_attribute({Location.txt = "ocaml.ppx.context"}, a)}
+ :: items ->
+ if restore then
+ PpxContext.restore (PpxContext.get_fields a);
+ items
+ | items -> items
+
+let add_ppx_context_str ~tool_name ast =
+ Ast_helper.Str.attribute (ppx_context ~tool_name ()) :: ast
+
+let add_ppx_context_sig ~tool_name ast =
+ Ast_helper.Sig.attribute (ppx_context ~tool_name ()) :: ast
+
+
+let apply ~source ~target mapper =
+ apply_lazy ~source ~target (fun () -> mapper)
+
let run_main mapper =
try
let a = Sys.argv in
let n = Array.length a in
if n > 2 then
- let mapper =
+ let mapper () =
try mapper (Array.to_list (Array.sub a 1 (n - 3)))
with exn ->
(* PR #6463 *)
let f _ _ = raise exn in
{default_mapper with structure = f; signature = f}
in
- apply ~source:a.(n - 2) ~target:a.(n - 1) mapper
+ apply_lazy ~source:a.(n - 2) ~target:a.(n - 1) mapper
else begin
Printf.eprintf "Usage: %s [extra_args] <infile> <outfile>\n%!"
Sys.executable_name;
let register_function = ref (fun _name f -> run_main f)
let register name f = !register_function name f
-
-
-let ppx_context ~tool_name () =
- let open Longident in
- let open Asttypes in
- let open Ast_helper in
- let lid name = { txt = Lident name; loc = Location.none } in
- let make_string x = Exp.constant (Const_string (x, None)) in
- let make_bool x =
- if x
- then Exp.construct (lid "true") None
- else Exp.construct (lid "false") None
- in
- let rec make_list f lst =
- match lst with
- | x :: rest ->
- Exp.construct (lid "::") (Some (Exp.tuple [f x; make_list f rest]))
- | [] ->
- Exp.construct (lid "[]") None
- in
- let make_option f opt =
- match opt with
- | Some x -> Exp.construct (lid "Some") (Some (f x))
- | None -> Exp.construct (lid "None") None
- in
- { txt = "ocaml.ppx.context"; loc = Location.none },
- Parsetree.PStr [Str.eval (
- Exp.record ([
- lid "tool_name", make_string tool_name;
- lid "include_dirs", make_list make_string !Clflags.include_dirs;
- lid "load_path", make_list make_string !Config.load_path;
- lid "open_modules", make_list make_string !Clflags.open_modules;
- lid "for_package", make_option make_string !Clflags.for_package;
- lid "debug", make_bool !Clflags.debug;
- ]) None)]
(* *)
(***********************************************************************)
-(** Helpers to write Parsetree rewriters *)
+(** The interface of a -ppx rewriter
+
+ A -ppx rewriter is a program that accepts a serialized abstract syntax
+ tree and outputs another, possibly modified, abstract syntax tree.
+ This module encapsulates the interface between the compiler and
+ the -ppx rewriters, handling such details as the serialization format,
+ forwarding of command-line flags, and storing state.
+
+ {!mapper} allows to implement AST rewriting using open recursion.
+ A typical mapper would be based on {!default_mapper}, a deep
+ identity mapper, and will fall back on it for handling the syntax it
+ does not modify. For example:
+
+ {[
+open Asttypes
+open Parsetree
+open Ast_mapper
+
+let test_mapper argv =
+ { default_mapper with
+ expr = fun mapper expr ->
+ match expr with
+ | { pexp_desc = Pexp_extension ({ txt = "test" }, PStr [])} ->
+ Ast_helper.Exp.constant (Const_int 42)
+ | other -> default_mapper.expr mapper other; }
+
+let () =
+ register "ppx_test" test_mapper]}
+
+ This -ppx rewriter, which replaces [[%test]] in expressions with
+ the constant [42], can be compiled using
+ [ocamlc -o ppx_test -I +compiler-libs ocamlcommon.cma ppx_test.ml].
+
+ *)
open Parsetree
val register_function: (string -> (string list -> mapper) -> unit) ref
val register: string -> (string list -> mapper) -> unit
-
(** Apply the [register_function]. The default behavior is to run the
mapper immediately, taking arguments from the process command
line. This is to support a scenario where a mapper is linked as a
(** {2 Helper functions to call external mappers} *)
-val ppx_context: tool_name:string -> unit -> Parsetree.attribute
+val add_ppx_context_str: tool_name:string -> Parsetree.structure -> Parsetree.structure
(** Extract information from the current environment and encode it
- into an attribute an attribute which can be prepended to
- signature/structure items of an AST to pass the information to an
- external processor. *)
+ into an attribute which is prepended to the list of structure
+ items in order to pass the information to an external
+ processor. *)
+
+val add_ppx_context_sig: tool_name:string -> Parsetree.signature -> Parsetree.signature
+(** Same as [add_ppx_context_str], but for signatures. *)
+
+val drop_ppx_context_str: restore:bool -> Parsetree.structure -> Parsetree.structure
+(** Drop the ocaml.ppx.context attribute from a structure. If
+ [restore] is true, also restore the associated data in the current
+ process. *)
+
+val drop_ppx_context_sig: restore:bool -> Parsetree.signature -> Parsetree.signature
+(** Same as [drop_ppx_context_str], but for signatures. *)
+
+(** {2 Cookies} *)
+
+(** Cookies are used to pass information from a ppx processor to
+ a further invocation of itself, when called from the OCaml
+ toplevel (or other tools that support cookies). *)
+
+val set_cookie: string -> Parsetree.expression -> unit
+val get_cookie: string -> Parsetree.expression option
)
-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
functor_arg:
LPAREN RPAREN
- { mkrhs "()" 2, None }
+ { mkrhs "*" 2, None }
| LPAREN functor_arg_name COLON module_type RPAREN
{ mkrhs $2 2, Some $4 }
;
| 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] }
| 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
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
;;
(** 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
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
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
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
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}. *)
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;
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 =
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 =
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 =
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
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)
(******************************************************************************)
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;
| 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) ->
| 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 .
| 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 .
| 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) ->
(* 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
(* Add '0' padding to int, int32, nativeint or int64 string representation. *)
let fix_int_precision prec str =
+ let prec = abs prec in
let len = String.length str in
- if prec <= len then str else
+ match str.[0] with
+ | ('+' | '-' | ' ') as c when prec + 1 > len ->
+ let res = Bytes.make (prec + 1) '0' in
+ Bytes.set res 0 c;
+ String.blit str 1 res (prec - len + 2) (len - 1);
+ Bytes.unsafe_to_string res
+ | '0' when prec + 2 > len && len > 1 && (str.[1] = 'x' || str.[1] = 'X') ->
+ let res = Bytes.make (prec + 2) '0' in
+ Bytes.set res 1 str.[1];
+ String.blit str 2 res (prec - len + 4) (len - 2);
+ Bytes.unsafe_to_string res
+ | '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' when prec > len ->
let res = Bytes.make prec '0' in
- begin match str.[0] with
- | ('+' | '-' | ' ') as c ->
- Bytes.set res 0 c;
- String.blit str 1 res (prec - len + 1) (len - 1);
- | '0' when len > 1 && (str.[1] = 'x' || str.[1] = 'X') ->
- Bytes.set res 1 str.[1];
- String.blit str 2 res (prec - len + 2) (len - 2);
- | '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' ->
- String.blit str 0 res (prec - len) len;
- | _ ->
- assert false
- end;
+ String.blit str 0 res (prec - len) len;
Bytes.unsafe_to_string res
+ | _ ->
+ str
(* Escape a string according to the OCaml lexing convention. *)
let string_to_caml_string str =
(* 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 '%';
(* 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
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
| 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 "%_(". *)
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 =
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
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
(* 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) ->
| 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
| ',' ->
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') =
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
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' | '-' -> (
| _, 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 =
| 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
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
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)
| 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
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
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 *)
@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.
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]. *)
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].
*)
(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].
*)
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].
*)
type control =
{ mutable minor_heap_size : int;
(** The size (in words) of the minor heap. Changing
- this parameter will trigger a minor collection. Default: 32k. *)
+ this parameter will trigger a minor collection. Default: 256k. *)
mutable major_heap_increment : int;
(** How much to add to the major heap when increasing it. If this
mutable stack_limit : int;
(** The maximum size of the stack (in words). This is only
relevant to the byte-code runtime, as the native code runtime
- uses the operating system's stack. Default: 256k. *)
+ uses the operating system's stack. Default: 1024k. *)
mutable allocation_policy : int;
(** The policy used for allocating in the heap. Possible
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]. *)
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
(** 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."]
[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"
[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} *)
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,
| 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)
| 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 *)
| 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);
*)
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
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
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].
@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.
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].
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],
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
ABCDFILES=backtrace.ml
OTHERFILES=backtrace2.ml raw_backtrace.ml \
backtrace_deprecated.ml backtrace_slots.ml
+OTHERFILESNOINLINING=backtraces_and_finalizers.ml
default:
$(MAKE) byte
>$$F.native.result 2>&1; \
$(DIFF) $$F.reference $$F.native.result >/dev/null \
&& echo " => passed" || echo " => failed"; \
+ done;
+ @for file in $(OTHERFILESNOINLINING); do \
+ rm -f program program.exe; \
+ $(OCAMLOPT) -inline 0 -g -o $(EXECNAME) $$file; \
+ printf " ... testing '$$file' with ocamlopt:"; \
+ F="`basename $$file .ml`"; \
+ (OCAMLRUNPARAM=b=1 ./$(EXECNAME) $$arg || true) \
+ >$$F.native.result 2>&1; \
+ $(DIFF) $$F.reference $$F.native.result >/dev/null \
+ && echo " => passed" || echo " => failed"; \
done
.PHONY: promote
--- /dev/null
+let () = Printexc.record_backtrace true
+
+let finaliser _ = try raise Exit with _ -> ()
+
+let create () =
+ let x = ref () in
+ Gc.finalise finaliser x;
+ x
+
+let f () = raise Exit
+
+let () =
+ let minor_size = (Gc.get ()).Gc.minor_heap_size in
+ for i = 1 to 100 do
+ Gc.minor ();
+ try
+ ignore (create () : unit ref);
+ f ()
+ with _ ->
+ for i = 1 to minor_size / 2 - 1 do
+ ignore (ref ())
+ done;
+ ignore (Printexc.get_backtrace () : string)
+ done;
+ Printf.printf "ok\n"
--- /dev/null
+(***********************************************************************)
+(* *)
+(* OCaml *)
+(* *)
+(* Damien Doligez, EPI Gallium, INRIA Rocquencourt *)
+(* *)
+(* Copyright 2014 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0. *)
+(* *)
+(***********************************************************************)
+
+(* WARNING: this file MUST NOT be merged into the trunk, it is for the
+ 4.02 branch only, to test compatibility with the old implementation
+ of printf. Starting with 4.03, all these formats will be statically
+ refused by the compiler.
+*)
+
+open Printf;;
+
+let show arg f =
+ printf "%8s --> |" (string_of_format f);
+ printf f arg;
+ printf "|\n";
+in
+
+ List.iter (show 12.3) [
+ "%0.3f";
+ "%0.f";
+ "%+ .3f";
+ "%.f";
+ "%3.f";
+ "%-9.f";
+ "%0.16g";
+ ];
+
+ List.iter (show "ab") [
+ "%.30s";
+ "%-.30s";
+ "%-s";
+ "%0s";
+ "%03s";
+ "% s";
+ ];
+
+ List.iter (show 4) [
+ "%0.3d";
+ "%0X";
+ "%0x";
+ ];
+
+ List.iter (show 'a') [
+ "%5c";
+ ];
+;;
+
+let fmt = format_of_string "%0.*f" in
+printf "%8s --> |" (string_of_format fmt);
+printf fmt 3 12.3;
+printf "|\n";
+;;
+
+let fmt = format_of_string "%.2%" in
+printf "%8s --> |" (string_of_format fmt);
+printf fmt;
+printf "|\n";
+;;
--- /dev/null
+
+# * * * * # %0.3f --> |12.300|
+ %0.f --> |12|
+ %+ .3f --> |+12.300|
+ %.f --> |12|
+ %3.f --> | 12|
+ %-9.f --> |12 |
+ %0.16g --> |12.3|
+ %.30s --> | ab|
+ %-.30s --> |ab |
+ %-s --> |ab|
+ %0s --> |ab|
+ %03s --> | ab|
+ % s --> |ab|
+ %0.3d --> |004|
+ %0X --> |4|
+ %0x --> |4|
+ %5c --> |a|
+- : unit = ()
+# %0.*f --> |12.300|
+- : unit = ()
+# %.2% --> |%|
+- : unit = ()
+#
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 \
# #
#########################################################################
-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
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 ");
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 ");
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
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%!";
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@");
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\"");
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");
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");
test (sprintf "@@" = "@");
test (sprintf "@@@@" = "@@");
test (sprintf "@@%%" = "@%");
-
say "\nend of tests\n%!";
+
with e ->
say "unexpected exception: %s\n%!" (Printexc.to_string e);
test false;
d/i positive
- 0 1 2 3 4 5 6 7 8
+ 0 1 2 3 4 5 6 7 8 9
d/i negative
- 9 10 11 12 13 14 15 16 17
+ 10 11 12 13 14 15 16 17 18 19
u positive
- 18 19 20 21 22 23 24 25 26
+ 20 21 22 23 24 25 26 27 28
u negative
- 27
+ 29
x positive
- 28 29 30 31 32 33 34 35 36
+ 30 31 32 33 34 35 36 37 38 39 40 41 42
x negative
- 37
+ 43
X positive
- 38 39 40 41 42 43 44 45 46
+ 44 45 46 47 48 49 50 51 52
x negative
- 47
+ 53
o positive
- 48 49 50 51 52 53 54 55 56
+ 54 55 56 57 58 59 60 61 62
o negative
- 57
+ 63
s
- 58 59 60 61 62 63 64 65 66 67 68 69 70 71
+ 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78
S
- 72 73 74 75 76 77 78 79 80
+ 79 80 81 82 83 84 85 86 87 88 89 90 91
c
- 81 82 83 84
+ 92 93 94 95
C
- 85 86 87 88 89
+ 96 97 98 99 100
f
- 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107
+ 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118
F
- 108 109 110 111
+ 119 120 121 122 123 124 125
e
- 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129
+ 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143
E
- 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147
+ 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161
B
- 148 149
+ 162 163
ld/li positive
- 150 151 152 153 154 155 156 157 158
+ 164 165 166 167 168 169 170 171 172
ld/li negative
- 159 160 161 162 163 164 165 166 167
+ 173 174 175 176 177 178 179 180 181
lu positive
- 168 169 170 171 172 173 174 175 176
+ 182 183 184 185 186 187 188 189 190
lu negative
- 177
+ 191
lx positive
- 178 179 180 181 182 183 184 185 186
+ 192 193 194 195 196 197 198 199 200
lx negative
- 187
+ 201
lX positive
- 188 189 190 191 192 193 194 195 196
+ 202 203 204 205 206 207 208 209 210
lx negative
- 197
+ 211
lo positive
- 198 199 200 201 202 203 204 205 206
+ 212 213 214 215 216 217 218 219 220
lo negative
- 207
+ 221
Ld/Li positive
- 208 209 210 211 212 213 214 215 216
+ 222 223 224 225 226 227 228 229 230
Ld/Li negative
- 217 218 219 220 221 222 223 224 225
+ 231 232 233 234 235 236 237 238 239
Lu positive
- 226 227 228 229 230 231 232 233 234
+ 240 241 242 243 244 245 246 247 248
Lu negative
- 235
+ 249
Lx positive
- 236 237 238 239 240 241 242 243 244
+ 250 251 252 253 254 255 256 257 258
Lx negative
- 245
+ 259
LX positive
- 246 247 248 249 250 251 252 253 254
+ 260 261 262 263 264 265 266 267 268
Lx negative
- 255
+ 269
Lo positive
- 256 257 258 259 260 261 262 263 264
+ 270 271 272 273 274 275 276 277 278
Lo negative
- 265
+ 279
a
- 266
+ 280
t
- 267
+ 281
{...%}
- 268
+ 282
(...%)
- 269
+ 283
! % @ , and constants
- 270 271 272 273 274 275 276
+ 284 285 286 287 288 289 290
end of tests
All tests succeeded.
# #
#########################################################################
-#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
--- /dev/null
+(* 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";
+ ()
--- /dev/null
+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.
(*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' *)
(*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' *)
(* >> '#' 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
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
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' *)
(* >> '#' 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\"@");
(*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");
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");
d/i positive
- 0 1 2 3 4 5 6
+ 0 1 2 3 4 5 6 7
d/i negative
- 7 8 9 10 11 12 13
+ 8 9 10 11 12 13 14 15
u positive
- 14 15 16 17 18
+ 16 17 18 19 20 21
u negative
- 19
+ 22
x positive
- 20 21 22 23 24 25
+ 23 24 25 26 27 28 29 30 31 32 33
x negative
- 26
+ 34
X positive
- 27 28 29 30 31 32
+ 35 36 37 38 39 40
x negative
- 33
+ 41
o positive
- 34 35 36 37 38 39
+ 42 43 44 45 46 47
o negative
- 40
+ 48
s
- 41 42 43 44 45 46 47 48 49
+ 49 50 51 52 53 54 55 56 57 58
S
- 50 51 52 53 54 55
+ 59 60 61 62 63 64 65 66
c
- 56
+ 67
C
- 57 58
+ 68 69
f
- 59 60 61 62 63 64 65 66 67 68 69 70 71 72
+ 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84
F
- 73 74 75 76
+ 85 86 87 88 89 90 91
e
- 77 78 79 80 81 82 83 84 85 86 87 88 89 90
+ 92 93 94 95 96 97 98 99 100 101 102 103 104 105
E
- 91 92 93 94 95 96 97 98 99 100 101 102 103 104
+ 106 107 108 109 110 111 112 113 114 115 116 117 118 119
B
- 105 106
+ 120 121
ld/li positive
- 107 108 109 110 111 112 113
+ 122 123 124 125 126 127 128
ld/li negative
- 114 115 116 117 118 119 120
+ 129 130 131 132 133 134 135
lu positive
- 121 122 123 124 125
+ 136 137 138 139 140
lu negative
- 126
+ 141
lx positive
- 127 128 129 130 131 132
+ 142 143 144 145 146 147
lx negative
- 133
+ 148
lX positive
- 134 135 136 137 138 139
+ 149 150 151 152 153 154
lx negative
- 140
+ 155
lo positive
- 141 142 143 144 145 146
+ 156 157 158 159 160 161
lo negative
- 147
+ 162
Ld/Li positive
- 148 149 150 151 152
+ 163 164 165 166 167
Ld/Li negative
- 153 154 155 156 157
+ 168 169 170 171 172
Lu positive
- 158 159 160 161 162
+ 173 174 175 176 177
Lu negative
- 163
+ 178
Lx positive
- 164 165 166 167 168 169
+ 179 180 181 182 183 184
Lx negative
- 170
+ 185
LX positive
- 171 172 173 174 175 176
+ 186 187 188 189 190 191
Lx negative
- 177
+ 192
Lo positive
- 178 179 180 181 182 183
+ 193 194 195 196 197 198
Lo negative
- 184
+ 199
a
- 185
+ 200
t
- 186
+ 201
{...%}
- 187
+ 202
(...%)
- 188
+ 203
! % @ , and constants
- 189 190 191 192 193 194 195
+ 204 205 206 207 208 209 210
end of tests
All tests succeeded.
test (test58 ())
;;
+(* skip test number "59" which is commented below *)
+let () = test (true);;
(*
let test59 () =
;;
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 ());
- 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.
# #
#########################################################################
-BASEDIR=../..
+BASEDIR=../../..
MAIN_MODULE=debuggee
ADD_COMPFLAGS=-g -custom
LD_PATH=$(TOPDIR)/otherlibs/$(UNIXLIBVAR)unix
--- /dev/null
+compiler-libs
+out
+c
+c.exe
--- /dev/null
+#########################################################################
+# #
+# 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
--- /dev/null
+let () =
+ print_int Foo.A.x;
+ print_newline ()
--- /dev/null
+
+(ocd) Loading program... done.
+1
+Program exit.
^^^^^^^^^^^^^^^^^^
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>
--- /dev/null
+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
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;;
sig module N = M.N module P = M.P end
In module Q.N:
Modules do not match: sig end is not included in (module M.N)
+# module M : sig val f : 'a -> 'a end
+module rec R : sig module M : sig val f : 'a -> 'a end end
+# - : int = 3
+# module rec R : sig module M = M end
+# - : int = 3
#
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;;
# 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
#
-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 \
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 :
let free_structure_names = ref StringSet.empty
-let rec addmodule bv lid =
- match lid with
- Lident s ->
+let rec add_path bv = function
+ | Lident s ->
if not (StringSet.mem s bv)
then free_structure_names := StringSet.add s !free_structure_names
- | Ldot(l, _s) -> addmodule bv l
- | Lapply(l1, l2) -> addmodule bv l1; addmodule bv l2
+ | Ldot(l, _s) -> add_path bv l
+ | Lapply(l1, l2) -> add_path bv l1; add_path bv l2
+
+let open_module bv lid = add_path bv lid
let add bv lid =
match lid.txt with
- Ldot(l, _s) -> addmodule bv l
+ Ldot(l, _s) -> add_path bv l
| _ -> ()
-let addmodule bv lid = addmodule bv lid.txt
+let addmodule bv lid = add_path bv lid.txt
let rec add_type bv ty =
match ty.ptyp_desc with
let bv = add_pattern bv pat in List.iter (add_class_field bv) fieldl
| Pexp_newtype (_, e) -> add_expr bv e
| Pexp_pack m -> add_module bv m
- | Pexp_open (_ovf, m, e) -> addmodule bv m; add_expr bv e
+ | Pexp_open (_ovf, m, e) -> open_module bv m.txt; add_expr bv e
| Pexp_extension _ -> ()
and add_cases bv cases =
end;
bv
| Psig_open od ->
- addmodule bv od.popen_lid; bv
+ open_module bv od.popen_lid.txt; bv
| Psig_include incl ->
add_modtype bv incl.pincl_mod; bv
| Psig_class cdl ->
end;
bv
| Pstr_open od ->
- addmodule bv od.popen_lid; bv
+ open_module bv od.popen_lid.txt; bv
| Pstr_class cdl ->
List.iter (add_class_declaration bv) cdl; bv
| Pstr_class_type cdtl ->
val free_structure_names : StringSet.t ref
+val open_module : StringSet.t -> Longident.t -> unit
+
val add_use_file : StringSet.t -> Parsetree.toplevel_phrase list -> unit
val add_signature : StringSet.t -> Parsetree.signature -> unit
dirs := StringMap.add dir contents !dirs;
contents
+let add_to_list li s =
+ li := s :: !li
+
let add_to_load_path dir =
try
let dir = Misc.expand_directory Config.standard_library dir in
let contents = readdir dir in
- load_path := (dir, contents) :: !load_path
+ add_to_list load_path (dir, contents)
with Sys_error msg ->
Format.fprintf Format.err_formatter "@[Bad -I option: %s@]@." msg;
error_occurred := true
let add_to_synonym_list synonyms suffix =
if (String.length suffix) > 1 && suffix.[0] = '.' then
- synonyms := suffix :: !synonyms
+ add_to_list synonyms suffix
else begin
Format.fprintf Format.err_formatter "@[Bad suffix: '%s'@]@." suffix;
error_occurred := true
let input_file = Pparse.preprocess source_file in
begin try
let ast =
- Pparse.file ~tool_name Format.err_formatter input_file parse_function magic in
- extract_function Depend.StringSet.empty ast;
+ Pparse.file ~tool_name Format.err_formatter
+ input_file parse_function magic
+ in
+ let bound_vars = Depend.StringSet.empty in
+ List.iter (fun modname ->
+ Depend.open_module bound_vars (Longident.Lident modname)
+ ) !Clflags.open_modules;
+ extract_function bound_vars ast;
Pparse.remove_preprocessed input_file;
!Depend.free_structure_names
with x ->
let _ =
Clflags.classic := false;
- first_include_dirs := Filename.current_dir_name :: !first_include_dirs;
+ add_to_list first_include_dirs Filename.current_dir_name;
Compenv.readenv ppf Before_args;
Arg.parse [
"-absname", Arg.Set Location.absname,
" Show absolute filenames in error messages";
"-all", Arg.Set all_dependencies,
" Generate dependencies on all files";
- "-I", Arg.String (fun s -> Clflags.include_dirs := s :: !Clflags.include_dirs),
+ "-I", Arg.String (add_to_list Clflags.include_dirs),
"<dir> Add <dir> to the list of include directories";
"-impl", Arg.String (file_dependencies_as ML),
"<f> Process <f> as a .ml file";
" Generate dependencies for native-code only (no .cmo files)";
"-one-line", Arg.Set one_line,
" Output one line per file, regardless of the length";
+ "-open", Arg.String (add_to_list Clflags.open_modules),
+ "<module> Opens the module <module> before typing";
"-pp", Arg.String(fun s -> Clflags.preprocessor := Some s),
"<cmd> Pipe sources through preprocessor <cmd>";
- "-ppx", Arg.String(fun s -> first_ppx := s :: !first_ppx),
+ "-ppx", Arg.String (add_to_list first_ppx),
"<cmd> Pipe abstract syntax trees through preprocessor <cmd>";
"-slash", Arg.Set Clflags.force_slash,
" (Windows) Use forward slash / instead of backslash \\ in file paths";
try
List.iter
(fun (name, crco) ->
- Env.imported_units := name :: !Env.imported_units;
+ Env.add_import name;
match crco with
None -> ()
| Some crc->
(* 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 ->
let use_print_results = ref true
-let phrase ppf phr =
+let preprocess_phrase ppf phr =
let phr =
match phr with
| Ptop_def str ->
- Ptop_def (Pparse.apply_rewriters ~tool_name:"ocaml" ast_impl_magic_number str)
+ let str =
+ Pparse.apply_rewriters_str ~restore:true ~tool_name:"ocaml" str
+ in
+ Ptop_def str
| phr -> phr
in
if !Clflags.dump_parsetree then Printast.top_phrase ppf phr;
try
List.iter
(fun ph ->
- let ph = phrase ppf ph in
+ let ph = preprocess_phrase ppf ph in
if not (execute_phrase !use_print_results ppf ph) then raise Exit)
(if wrap_mod then
parse_mod_use_file name lb
Compmisc.init_path false;
List.iter
(fun (name, crco) ->
- Env.imported_units := name :: !Env.imported_units;
+ Env.add_import name;
match crco with
None -> ()
| Some crc->
Location.reset();
first_line := true;
let phr = try !parse_toplevel_phrase lb with Exit -> raise PPerror in
- let phr = phrase ppf phr in
+ let phr = preprocess_phrase ppf phr in
Env.reset_cache_toplevel ();
ignore(execute_phrase true ppf phr)
with
phrase executed with no errors and [false] otherwise.
First bool says whether the values and types of the results
should be printed. Uncaught exceptions are always printed. *)
+val preprocess_phrase : formatter -> Parsetree.toplevel_phrase -> Parsetree.toplevel_phrase
+ (* Preprocess the given toplevel phrase using regular and ppx
+ preprocessors. Return the updated phrase. *)
val use_file : formatter -> string -> bool
val use_silently : formatter -> string -> bool
val mod_use_file : formatter -> string -> bool
let newargs = Array.sub Sys.argv !Arg.current
(Array.length Sys.argv - !Arg.current)
in
+ Compenv.readenv ppf Before_link;
if prepare ppf && Toploop.run_script ppf name newargs
then exit 0
else exit 2
ps_sig: signature;
ps_comps: module_components;
ps_crcs: (string * Digest.t option) list;
+ mutable ps_crcs_checked: bool;
ps_filename: string;
ps_flags: pers_flags list }
(* Consistency between persistent structures *)
let crc_units = Consistbl.create()
-let imported_units = ref ([] : string list)
+
+module StringSet =
+ Set.Make(struct type t = string let compare = String.compare end)
+
+let imported_units = ref StringSet.empty
+
+let add_import s =
+ imported_units := StringSet.add s !imported_units
let clear_imports () =
Consistbl.clear crc_units;
- imported_units := []
+ imported_units := StringSet.empty
let check_consistency ps =
+ if not ps.ps_crcs_checked then
try
List.iter
(fun (name, crco) ->
match crco with
None -> ()
| Some crc ->
- imported_units := name :: !imported_units;
+ add_import name;
Consistbl.check crc_units name crc ps.ps_filename)
- ps.ps_crcs
+ ps.ps_crcs;
+ ps.ps_crcs_checked <- true;
with Consistbl.Inconsistency(name, source, auth) ->
error (Inconsistent_import(name, auth, source))
ps_comps = comps;
ps_crcs = crcs;
ps_filename = filename;
- ps_flags = flags } in
+ ps_flags = flags;
+ ps_crcs_checked = false;
+ } in
if ps.ps_name <> modname then
error (Illegal_renaming(modname, ps.ps_name, filename));
- imported_units := name :: !imported_units;
+ add_import name;
List.iter
(function Rectypes ->
if not !Clflags.recursive_types then
(* Return the list of imported interfaces with their CRCs *)
let imports() =
- Consistbl.extract !imported_units crc_units
+ Consistbl.extract (StringSet.elements !imported_units) crc_units
(* Save a signature to a file *)
ps_comps = comps;
ps_crcs = (cmi.cmi_name, Some crc) :: imports;
ps_filename = filename;
- ps_flags = cmi.cmi_flags } in
+ ps_flags = cmi.cmi_flags;
+ ps_crcs_checked = false;
+ } in
Hashtbl.add persistent_structures modname (Some ps);
Consistbl.set crc_units modname crc filename;
- imported_units := modname :: !imported_units;
+ add_import modname;
sg
with exn ->
close_out oc;
(* Direct access to the table of imported compilation units with their CRC *)
val crc_units: Consistbl.t
-val imported_units: string list ref
+val add_import: string -> unit
(* Summaries -- compact representation of an environment, to be
exported in debugging information. *)
(* 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 *)
(* 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 *)
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
(* Inclusion between signature components *)
-and signature_components env cxt subst = function
+and signature_components old_env env cxt subst paired =
+ let comps_rec rem = signature_components old_env env cxt subst rem in
+ match paired with
[] -> []
| (Sig_value(id1, valdecl1), Sig_value(id2, valdecl2), pos) :: rem ->
let cc = value_descriptions env cxt subst id1 valdecl1 valdecl2 in
begin match valdecl2.val_kind with
- Val_prim p -> signature_components env cxt subst rem
- | _ -> (pos, cc) :: signature_components env cxt subst rem
+ Val_prim p -> comps_rec rem
+ | _ -> (pos, cc) :: comps_rec rem
end
| (Sig_type(id1, tydecl1, _), Sig_type(id2, tydecl2, _), pos) :: rem ->
- type_declarations env cxt subst id1 tydecl1 tydecl2;
- signature_components env cxt subst rem
+ type_declarations ~old_env env cxt subst id1 tydecl1 tydecl2;
+ comps_rec rem
| (Sig_typext(id1, ext1, _), Sig_typext(id2, ext2, _), pos)
:: rem ->
extension_constructors env cxt subst id1 ext1 ext2;
- (pos, Tcoerce_none) :: signature_components env cxt subst rem
+ (pos, Tcoerce_none) :: comps_rec rem
| (Sig_module(id1, mty1, _), Sig_module(id2, mty2, _), pos) :: rem ->
let cc =
modtypes env (Module id1::cxt) subst
(Mtype.strengthen env mty1.md_type (Pident id1)) mty2.md_type in
- (pos, cc) :: signature_components env cxt subst rem
+ (pos, cc) :: comps_rec rem
| (Sig_modtype(id1, info1), Sig_modtype(id2, info2), pos) :: rem ->
modtype_infos env cxt subst id1 info1 info2;
- signature_components env cxt subst rem
+ comps_rec rem
| (Sig_class(id1, decl1, _), Sig_class(id2, decl2, _), pos) :: rem ->
- class_declarations env cxt subst id1 decl1 decl2;
- (pos, Tcoerce_none) :: signature_components env cxt subst rem
+ class_declarations ~old_env env cxt subst id1 decl1 decl2;
+ (pos, Tcoerce_none) :: comps_rec rem
| (Sig_class_type(id1, info1, _),
Sig_class_type(id2, info2, _), pos) :: rem ->
- class_type_declarations env cxt subst id1 info1 info2;
- signature_components env cxt subst rem
+ class_type_declarations ~old_env env cxt subst id1 info1 info2;
+ comps_rec rem
| _ ->
assert false
| 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
| [] ->
| 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 ->
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
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;
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
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" []
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 ->
let source tbl name = snd (Hashtbl.find tbl name)
let extract l tbl =
+ let l = List.sort_uniq String.compare l in
List.fold_left
(fun assc name ->
- try
- ignore (List.assoc name assc);
- assc
- with Not_found ->
try
let (crc, _) = Hashtbl.find tbl name in
(name, Some crc) :: assc
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
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
projects / ocaml.git / commitdiff