merge changes from 3.12.0 to 3.12.1
git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@11123 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02master
Damien Doligez
parent
46d5420ca9
commit
c91db736b1
36
.depend
36
.depend
|
|
@ -317,13 +317,13 @@ bytecomp/translobj.cmi: bytecomp/lambda.cmi typing/ident.cmi typing/env.cmi
|
|||
bytecomp/typeopt.cmi: typing/typedtree.cmi typing/path.cmi \
|
||||
bytecomp/lambda.cmi
|
||||
bytecomp/bytegen.cmo: typing/types.cmi bytecomp/switch.cmi typing/subst.cmi \
|
||||
typing/stypes.cmi typing/primitive.cmi utils/misc.cmi bytecomp/lambda.cmi \
|
||||
typing/primitive.cmi utils/misc.cmi bytecomp/lambda.cmi \
|
||||
bytecomp/instruct.cmi typing/ident.cmi utils/config.cmi \
|
||||
parsing/asttypes.cmi typing/annot.cmi bytecomp/bytegen.cmi
|
||||
parsing/asttypes.cmi bytecomp/bytegen.cmi
|
||||
bytecomp/bytegen.cmx: typing/types.cmx bytecomp/switch.cmx typing/subst.cmx \
|
||||
typing/stypes.cmx typing/primitive.cmx utils/misc.cmx bytecomp/lambda.cmx \
|
||||
typing/primitive.cmx utils/misc.cmx bytecomp/lambda.cmx \
|
||||
bytecomp/instruct.cmx typing/ident.cmx utils/config.cmx \
|
||||
parsing/asttypes.cmi typing/annot.cmi bytecomp/bytegen.cmi
|
||||
parsing/asttypes.cmi bytecomp/bytegen.cmi
|
||||
bytecomp/bytelibrarian.cmo: utils/misc.cmi utils/config.cmi \
|
||||
bytecomp/cmo_format.cmi utils/clflags.cmi bytecomp/bytelink.cmi \
|
||||
bytecomp/bytelibrarian.cmi
|
||||
|
|
@ -406,10 +406,12 @@ bytecomp/printlambda.cmx: typing/types.cmx typing/primitive.cmx \
|
|||
parsing/asttypes.cmi bytecomp/printlambda.cmi
|
||||
bytecomp/runtimedef.cmo: bytecomp/runtimedef.cmi
|
||||
bytecomp/runtimedef.cmx: bytecomp/runtimedef.cmi
|
||||
bytecomp/simplif.cmo: bytecomp/lambda.cmi typing/ident.cmi utils/clflags.cmi \
|
||||
parsing/asttypes.cmi bytecomp/simplif.cmi
|
||||
bytecomp/simplif.cmx: bytecomp/lambda.cmx typing/ident.cmx utils/clflags.cmx \
|
||||
parsing/asttypes.cmi bytecomp/simplif.cmi
|
||||
bytecomp/simplif.cmo: typing/stypes.cmi bytecomp/lambda.cmi typing/ident.cmi \
|
||||
utils/clflags.cmi parsing/asttypes.cmi typing/annot.cmi \
|
||||
bytecomp/simplif.cmi
|
||||
bytecomp/simplif.cmx: typing/stypes.cmx bytecomp/lambda.cmx typing/ident.cmx \
|
||||
utils/clflags.cmx parsing/asttypes.cmi typing/annot.cmi \
|
||||
bytecomp/simplif.cmi
|
||||
bytecomp/switch.cmo: bytecomp/switch.cmi
|
||||
bytecomp/switch.cmx: bytecomp/switch.cmi
|
||||
bytecomp/symtable.cmo: utils/tbl.cmi bytecomp/runtimedef.cmi \
|
||||
|
|
@ -601,9 +603,9 @@ asmcomp/codegen.cmx: asmcomp/split.cmx asmcomp/spill.cmx asmcomp/reload.cmx \
|
|||
asmcomp/coloring.cmo: asmcomp/reg.cmi asmcomp/proc.cmi asmcomp/coloring.cmi
|
||||
asmcomp/coloring.cmx: asmcomp/reg.cmx asmcomp/proc.cmx asmcomp/coloring.cmi
|
||||
asmcomp/comballoc.cmo: asmcomp/reg.cmi asmcomp/mach.cmi utils/config.cmi \
|
||||
asmcomp/comballoc.cmi
|
||||
asmcomp/arch.cmo asmcomp/comballoc.cmi
|
||||
asmcomp/comballoc.cmx: asmcomp/reg.cmx asmcomp/mach.cmx utils/config.cmx \
|
||||
asmcomp/comballoc.cmi
|
||||
asmcomp/arch.cmx asmcomp/comballoc.cmi
|
||||
asmcomp/compilenv.cmo: utils/misc.cmi typing/ident.cmi typing/env.cmi \
|
||||
utils/config.cmi asmcomp/cmx_format.cmi asmcomp/clambda.cmi \
|
||||
asmcomp/compilenv.cmi
|
||||
|
|
@ -684,12 +686,14 @@ asmcomp/schedgen.cmx: asmcomp/reg.cmx utils/misc.cmx asmcomp/mach.cmx \
|
|||
asmcomp/schedgen.cmi
|
||||
asmcomp/scheduling.cmo: asmcomp/schedgen.cmi asmcomp/scheduling.cmi
|
||||
asmcomp/scheduling.cmx: asmcomp/schedgen.cmx asmcomp/scheduling.cmi
|
||||
asmcomp/selectgen.cmo: utils/tbl.cmi asmcomp/reg.cmi asmcomp/proc.cmi \
|
||||
utils/misc.cmi asmcomp/mach.cmi typing/ident.cmi asmcomp/debuginfo.cmi \
|
||||
asmcomp/cmm.cmi asmcomp/arch.cmo asmcomp/selectgen.cmi
|
||||
asmcomp/selectgen.cmx: utils/tbl.cmx asmcomp/reg.cmx asmcomp/proc.cmx \
|
||||
utils/misc.cmx asmcomp/mach.cmx typing/ident.cmx asmcomp/debuginfo.cmx \
|
||||
asmcomp/cmm.cmx asmcomp/arch.cmx asmcomp/selectgen.cmi
|
||||
asmcomp/selectgen.cmo: utils/tbl.cmi bytecomp/simplif.cmi asmcomp/reg.cmi \
|
||||
asmcomp/proc.cmi utils/misc.cmi asmcomp/mach.cmi typing/ident.cmi \
|
||||
asmcomp/debuginfo.cmi asmcomp/cmm.cmi asmcomp/arch.cmo \
|
||||
asmcomp/selectgen.cmi
|
||||
asmcomp/selectgen.cmx: utils/tbl.cmx bytecomp/simplif.cmx asmcomp/reg.cmx \
|
||||
asmcomp/proc.cmx utils/misc.cmx asmcomp/mach.cmx typing/ident.cmx \
|
||||
asmcomp/debuginfo.cmx asmcomp/cmm.cmx asmcomp/arch.cmx \
|
||||
asmcomp/selectgen.cmi
|
||||
asmcomp/selection.cmo: asmcomp/selectgen.cmi asmcomp/reg.cmi asmcomp/proc.cmi \
|
||||
utils/misc.cmi asmcomp/mach.cmi asmcomp/debuginfo.cmi asmcomp/cmm.cmi \
|
||||
utils/clflags.cmi asmcomp/arch.cmo asmcomp/selection.cmi
|
||||
|
|
|
|||
98
Changes
98
Changes
|
|
@ -22,6 +22,104 @@ Standard library:
|
|||
Bug Fixes:
|
||||
|
||||
|
||||
Objective Caml 3.12.1:
|
||||
----------------------
|
||||
|
||||
Bug fixes:
|
||||
- PR#4345, PR#4767: problems with camlp4 printing of float values
|
||||
- PR#4380: ocamlbuild should not use tput on windows
|
||||
- PR#4487, PR#5164: multiple 'module type of' are incompatible
|
||||
- PR#4552: ocamlbuild does not create symlinks when using '.itarget' file
|
||||
- PR#4673, PR#5144: camlp4 fails on object copy syntax
|
||||
- PR#4702: system threads: cleanup tick thread at exit
|
||||
- PR#4732: camlp4 rejects polymorphic variants using keywords from macros
|
||||
- PR#4778: Win32/MSVC port: rare syntax error in generated MASM assembly file
|
||||
- PR#4794, PR#4959: call annotations not generated by ocamlopt
|
||||
- PR#4820: revised syntax pretty printer crashes with 'Stack_overflow'
|
||||
- PR#4928: wrong printing of classes and class types by camlp4
|
||||
- PR#4939: camlp4 rejects patterns of the '?x:_' form
|
||||
- PR#4967: ocamlbuild passes wrong switches to ocamldep through menhir
|
||||
- PR#4972: mkcamlp4 does not include 'dynlink.cma'
|
||||
- PR#5039: ocamlbuild should use '-linkpkg' only when linking programs
|
||||
- PR#5066: ocamldoc: add -charset option used in html generator
|
||||
- PR#5069: fcntl() in caml_sys_open may block, do it within blocking section
|
||||
- PR#5071, PR#5129, PR#5134: inconsistencies between camlp4 and camlp4* binaries
|
||||
- PR#5080, PR#5104: regression in type constructor handling by camlp4
|
||||
- PR#5090: bad interaction between toplevel and camlp4
|
||||
- PR#5095: ocamlbuild ignores some tags when building bytecode objects
|
||||
- PR#5100: ocamlbuild always rebuilds a 'cmxs' file
|
||||
- PR#5103: build and install objinfo when building with ocamlbuild
|
||||
- PR#5109: crash when a parser calls a lexer that calls another parser
|
||||
- PR#5110: invalid module name when using optional argument
|
||||
- PR#5115: bytecode executables produced by msvc64 port crash on 32-bit versions
|
||||
- PR#5117: bigarray: wrong function name without HAS_MMAP; missing include
|
||||
- PR#5118: Camlp4o and integer literals
|
||||
- PR#5122: camlp4 rejects lowercase identifiers for module types
|
||||
- PR#5123: shift_right_big_int returns a wrong zero
|
||||
- PR#5124: substitution inside a signature leads to odd printing
|
||||
- PR#5128: typo in 'Camlp4ListComprehension' syntax extension
|
||||
- PR#5136: obsolete function used in emacs mode
|
||||
- PR#5145: ocamldoc: missing html escapes
|
||||
- PR#5146: problem with spaces in multi-line string constants
|
||||
- PR#5149: (partial) various documentation problems
|
||||
- PR#5156: rare compiler crash with objects
|
||||
- PR#5165: ocamlbuild does not pass '-thread' option to ocamlfind
|
||||
- PR#5167: camlp4r loops when printing package type
|
||||
- PR#5172: camlp4 support for 'module type of' construct
|
||||
- PR#5175: in bigarray accesses, make sure bigarray expr is evaluated only once
|
||||
- PR#5177: Gc.compact implies Gc.full_major
|
||||
- PR#5182: use bytecode version of ocamldoc to generate man pages
|
||||
- PR#5184: under Windows, alignment issue with bigarrays mapped from files
|
||||
- PR#5188: double-free corruption in bytecode system threads
|
||||
- PR#5192: mismatch between words and bytes in interpreting max_young_wosize
|
||||
- PR#5202: error in documentation of atan2
|
||||
- PR#5209: natdynlink incorrectly detected on BSD systems
|
||||
- PR#5213: ocamlbuild should pass '-rectypes' to ocamldoc when needed
|
||||
- PR#5217: ocamlfind plugin should add '-linkpkg' for toplevel
|
||||
- PR#5228: document the exceptions raised by functions in 'Filename'
|
||||
- PR#5229: typo in build script ('TAG_LINE' vs 'TAGLINE')
|
||||
- PR#5230: error in documentation of Scanf.Scanning.open_in
|
||||
- PR#5234: option -shared reverses order of -cclib options
|
||||
- PR#5237: incorrect .size directives generated for x86-32 and x86-64
|
||||
- PR#5244: String.compare uses polymorphic compare_val (regression of PR#4194)
|
||||
- PR#5248: regression introduced while fixing PR#5118
|
||||
- PR#5252: typo in docs
|
||||
- PR#5258: win32unix: unix fd leak under windows
|
||||
- PR#5269: (tentative fix) Wrong ext_ref entries in .annot files
|
||||
- PR#5272: caml.el doesn't recognize downto as a keyword
|
||||
- PR#5276: issue with ocamlc -pack and recursively-packed modules
|
||||
- PR#5280: alignment constraints incorrectly autodetected on MIPS 32
|
||||
- PR#5281: typo in error message
|
||||
- PR#5308: unused variables not detected in "include (struct .. end)"
|
||||
- camlp4 revised syntax printing bug in the toplevel (reported on caml-list)
|
||||
- configure: do not define _WIN32 under cygwin
|
||||
- Hardened generic comparison in the case where two custom blocks
|
||||
are compared and have different sets of custom operations.
|
||||
- Hardened comparison between bigarrays in the case where the two
|
||||
bigarrays have different kinds.
|
||||
- Fixed wrong autodetection of expm1() and log1p().
|
||||
- don't add .exe suffix when installing the ocamlmktop shell script
|
||||
- ocamldoc: minor fixes related to the display of ocamldoc options
|
||||
- fixed bug with huge values in OCAMLRUNPARAM
|
||||
- mismatch between declaration and definition of caml_major_collection_slice
|
||||
|
||||
Feature wishes:
|
||||
- PR#4992: added '-ml-synonym' and '-mli-synonym' options to ocamldep
|
||||
- PR#5065: added '-ocamldoc' option to ocamlbuild
|
||||
- PR#5139: added possibility to add options to ocamlbuild
|
||||
- PR#5158: added access to current camlp4 parsers and printers
|
||||
- PR#5180: improved instruction selection for float operations on amd64
|
||||
- stdlib: added a 'usage_string' function to Arg
|
||||
- allow with constraints to add a type equation to a datatype definition
|
||||
- ocamldoc: allow to merge '@before' tags like other ones
|
||||
- ocamlbuild: allow dependency on file "_oasis"
|
||||
|
||||
Other changes:
|
||||
- Changed default minor heap size from 32k to 256k words.
|
||||
- Added new operation 'compare_ext' to custom blocks, called when
|
||||
comparing a custom block value with an unboxed integer.
|
||||
|
||||
|
||||
Objective Caml 3.12.0:
|
||||
----------------------
|
||||
|
||||
|
|
|
|||
4
INSTALL
4
INSTALL
|
|
@ -255,10 +255,6 @@ From the top directory, become superuser and do:
|
|||
umask 022 # make sure to give read & execute permission to all
|
||||
make install
|
||||
|
||||
In the ocamlbuild setting instead of make install do:
|
||||
|
||||
./build/install.sh
|
||||
|
||||
7- Installation is complete. Time to clean up. From the toplevel
|
||||
directory, do "make clean".
|
||||
|
||||
|
|
|
|||
5
LICENSE
5
LICENSE
|
|
@ -6,8 +6,9 @@ INRIA" in the following directories and their sub-directories:
|
|||
and "the Compiler" refers to all files marked "Copyright INRIA" in the
|
||||
following directories and their sub-directories:
|
||||
|
||||
asmcomp, boot, bytecomp, debugger, driver, lex, ocamldoc, parsing,
|
||||
tools, toplevel, typing, utils, yacc
|
||||
asmcomp, boot, build, bytecomp, debugger, driver, lex, man,
|
||||
ocamlbuild, ocamldoc, parsing, testsuite, tools, toplevel, typing,
|
||||
utils, yacc
|
||||
|
||||
The Compiler is distributed under the terms of the Q Public License
|
||||
version 1.0 with a change to choice of law (included below).
|
||||
|
|
|
|||
2
README
2
README
|
|
@ -21,7 +21,7 @@ native-code compiler currently runs on the following platforms:
|
|||
|
||||
Tier 1 (actively used and maintained by the core Caml team):
|
||||
|
||||
AMD64 (Opteron) Linux
|
||||
AMD64 (Opteron) Linux, MacOS X, MS Windows
|
||||
IA32 (Pentium) Linux, FreeBSD, MacOS X, MS Windows
|
||||
PowerPC MacOS X
|
||||
|
||||
|
|
|
|||
12
README.win32
12
README.win32
|
|
@ -37,7 +37,7 @@ the GPL. Thus, these .exe files can only be distributed under a license
|
|||
that is compatible with the GPL. Executables generated by MSVC or by
|
||||
MinGW have no such restrictions.
|
||||
|
||||
(**) The debugger is supported but the "replay" function of it are not enabled.
|
||||
(**) The debugger is supported but the "replay" functions are not enabled.
|
||||
Other functions are available (step, goto, run...).
|
||||
|
||||
The remainder of this document gives more information on each port.
|
||||
|
|
@ -183,6 +183,10 @@ by Jacob Navia, then significantly improved by Christopher A. Watford.
|
|||
The native Win32 port built with Mingw
|
||||
--------------------------------------
|
||||
|
||||
NOTE: Due to changes in cygwin's compilers, this port is not available
|
||||
in OCaml 3.12.1. A patch will be made available soon after the release
|
||||
of 3.12.1.
|
||||
|
||||
REQUIREMENTS:
|
||||
|
||||
This port runs under MS Windows Vista, XP, and 2000.
|
||||
|
|
@ -232,7 +236,7 @@ You will need the following software components to perform the recompilation:
|
|||
- Windows NT, 2000, XP, or Vista.
|
||||
- Cygwin: http://sourceware.cygnus.com/cygwin/
|
||||
Install at least the following packages: binutils, diffutils,
|
||||
gcc-core, gcc-mingw-core, make, mingw-runtime, ncurses, w32-api.
|
||||
gcc-core, gcc-mingw-core, make, mingw-runtime, ncurses, w32api.
|
||||
- TCL/TK version 8.5 (see above).
|
||||
- The flexdll tool (see above).
|
||||
|
||||
|
|
@ -302,7 +306,9 @@ NOTES:
|
|||
|
||||
The libraries available in this port are "num", "str", "threads",
|
||||
"unix" and "labltk". "graph" is not available.
|
||||
The replay debugger is supported.
|
||||
The replay debugger is fully supported.
|
||||
When upgrading from 3.12.0 to 3.12.1, you will need to remove
|
||||
/usr/local/bin/ocamlmktop.exe before typing "make install".
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
|
|
|
|||
2
VERSION
2
VERSION
|
|
@ -1,4 +1,4 @@
|
|||
3.13.0+dev4 (2011-06-20)
|
||||
3.13.0+dev5 (2011-07-20)
|
||||
|
||||
# The version string is the first line of this file.
|
||||
# It must be in the format described in stdlib/sys.mli
|
||||
|
|
|
|||
|
|
@ -338,9 +338,12 @@ let emit_instr fallthrough i =
|
|||
| Lop(Imove | Ispill | Ireload) ->
|
||||
let src = i.arg.(0) and dst = i.res.(0) in
|
||||
if src.loc <> dst.loc then begin
|
||||
if src.typ = Float then
|
||||
` movsd {emit_reg src}, {emit_reg dst}\n`
|
||||
else
|
||||
match src.typ, src.loc, dst.loc with
|
||||
Float, Reg _, Reg _ ->
|
||||
` movapd {emit_reg src}, {emit_reg dst}\n`
|
||||
| Float, _, _ ->
|
||||
` movsd {emit_reg src}, {emit_reg dst}\n`
|
||||
| _ ->
|
||||
` movq {emit_reg src}, {emit_reg dst}\n`
|
||||
end
|
||||
| Lop(Iconst_int n) ->
|
||||
|
|
@ -359,7 +362,7 @@ let emit_instr fallthrough i =
|
|||
| _ ->
|
||||
let lbl = new_label() in
|
||||
float_constants := (lbl, s) :: !float_constants;
|
||||
` movlpd {emit_label lbl}(%rip), {emit_reg i.res.(0)}\n`
|
||||
` movsd {emit_label lbl}(%rip), {emit_reg i.res.(0)}\n`
|
||||
end
|
||||
| Lop(Iconst_symbol s) ->
|
||||
` {load_symbol_addr s}, {emit_reg i.res.(0)}\n`
|
||||
|
|
@ -412,7 +415,7 @@ let emit_instr fallthrough i =
|
|||
| Single ->
|
||||
` cvtss2sd {emit_addressing addr i.arg 0}, {emit_reg dest}\n`
|
||||
| Double | Double_u ->
|
||||
` movlpd {emit_addressing addr i.arg 0}, {emit_reg dest}\n`
|
||||
` movsd {emit_addressing addr i.arg 0}, {emit_reg dest}\n`
|
||||
end
|
||||
| Lop(Istore(chunk, addr)) ->
|
||||
begin match chunk with
|
||||
|
|
@ -428,7 +431,7 @@ let emit_instr fallthrough i =
|
|||
` cvtsd2ss {emit_reg i.arg.(0)}, %xmm15\n`;
|
||||
` movss %xmm15, {emit_addressing addr i.arg 1}\n`
|
||||
| Double | Double_u ->
|
||||
` movlpd {emit_reg i.arg.(0)}, {emit_addressing addr i.arg 1}\n`
|
||||
` movsd {emit_reg i.arg.(0)}, {emit_addressing addr i.arg 1}\n`
|
||||
end
|
||||
| Lop(Ialloc n) ->
|
||||
if !fastcode_flag then begin
|
||||
|
|
|
|||
|
|
@ -332,10 +332,13 @@ let emit_instr fallthrough i =
|
|||
| Lop(Imove | Ispill | Ireload) ->
|
||||
let src = i.arg.(0) and dst = i.res.(0) in
|
||||
if src.loc <> dst.loc then begin
|
||||
if src.typ = Float then
|
||||
` movsd {emit_reg dst}, {emit_reg src}\n`
|
||||
else
|
||||
` mov {emit_reg dst}, {emit_reg src}\n`
|
||||
match src.typ, src.loc, dst.loc with
|
||||
Float, Reg _, Reg _ ->
|
||||
` movapd {emit_reg dst}, {emit_reg src}\n`
|
||||
| Float, _, _ ->
|
||||
` movsd {emit_reg dst}, {emit_reg src}\n`
|
||||
| _ ->
|
||||
` mov {emit_reg dst}, {emit_reg src}\n`
|
||||
end
|
||||
| Lop(Iconst_int n) ->
|
||||
if n = 0n then begin
|
||||
|
|
@ -357,7 +360,7 @@ let emit_instr fallthrough i =
|
|||
| _ ->
|
||||
let lbl = new_label() in
|
||||
float_constants := (lbl, s) :: !float_constants;
|
||||
` movlpd {emit_reg i.res.(0)}, {emit_label lbl}\n`
|
||||
` movsd {emit_reg i.res.(0)}, {emit_label lbl}\n`
|
||||
end
|
||||
| Lop(Iconst_symbol s) ->
|
||||
add_used_symbol s;
|
||||
|
|
@ -418,7 +421,7 @@ let emit_instr fallthrough i =
|
|||
| Single ->
|
||||
` cvtss2sd {emit_reg dest}, REAL4 PTR {emit_addressing addr i.arg 0}\n`
|
||||
| Double | Double_u ->
|
||||
` movlpd {emit_reg dest}, REAL8 PTR {emit_addressing addr i.arg 0}\n`
|
||||
` movsd {emit_reg dest}, REAL8 PTR {emit_addressing addr i.arg 0}\n`
|
||||
end
|
||||
| Lop(Istore(chunk, addr)) ->
|
||||
begin match chunk with
|
||||
|
|
@ -434,7 +437,7 @@ let emit_instr fallthrough i =
|
|||
` cvtsd2ss xmm15, {emit_reg i.arg.(0)}\n`;
|
||||
` movss REAL4 PTR {emit_addressing addr i.arg 1}, xmm15\n`
|
||||
| Double | Double_u ->
|
||||
` movlpd REAL8 PTR {emit_addressing addr i.arg 1}, {emit_reg i.arg.(0)}\n`
|
||||
` movsd REAL8 PTR {emit_addressing addr i.arg 1}, {emit_reg i.arg.(0)}\n`
|
||||
end
|
||||
| Lop(Ialloc n) ->
|
||||
if !fastcode_flag then begin
|
||||
|
|
|
|||
|
|
@ -262,7 +262,7 @@ let link_shared ppf objfiles output_name =
|
|||
Clflags.ccobjs := !Clflags.ccobjs @ !lib_ccobjs;
|
||||
Clflags.ccopts := !lib_ccopts @ !Clflags.ccopts;
|
||||
let objfiles = List.rev (List.map object_file_name objfiles) @
|
||||
!Clflags.ccobjs in
|
||||
(List.rev !Clflags.ccobjs) in
|
||||
|
||||
let startup =
|
||||
if !Clflags.keep_startup_file
|
||||
|
|
|
|||
|
|
@ -544,7 +544,7 @@ let rec close fenv cenv = function
|
|||
| ((ufunct, _), uargs) ->
|
||||
(Ugeneric_apply(ufunct, uargs, Debuginfo.none), Value_unknown)
|
||||
end
|
||||
| Lsend(kind, met, obj, args) ->
|
||||
| Lsend(kind, met, obj, args, _) ->
|
||||
let (umet, _) = close fenv cenv met in
|
||||
let (uobj, _) = close fenv cenv obj in
|
||||
(Usend(kind, umet, uobj, close_list fenv cenv args, Debuginfo.none),
|
||||
|
|
|
|||
|
|
@ -580,32 +580,34 @@ let bigarray_word_kind = function
|
|||
| Pbigarray_complex64 -> Double
|
||||
|
||||
let bigarray_get unsafe elt_kind layout b args dbg =
|
||||
match elt_kind with
|
||||
Pbigarray_complex32 | Pbigarray_complex64 ->
|
||||
let kind = bigarray_word_kind elt_kind in
|
||||
let sz = bigarray_elt_size elt_kind / 2 in
|
||||
bind "addr" (bigarray_indexing unsafe elt_kind layout b args dbg) (fun addr ->
|
||||
box_complex
|
||||
(Cop(Cload kind, [addr]))
|
||||
(Cop(Cload kind, [Cop(Cadda, [addr; Cconst_int sz])])))
|
||||
| _ ->
|
||||
Cop(Cload (bigarray_word_kind elt_kind),
|
||||
[bigarray_indexing unsafe elt_kind layout b args dbg])
|
||||
bind "ba" b (fun b ->
|
||||
match elt_kind with
|
||||
Pbigarray_complex32 | Pbigarray_complex64 ->
|
||||
let kind = bigarray_word_kind elt_kind in
|
||||
let sz = bigarray_elt_size elt_kind / 2 in
|
||||
bind "addr" (bigarray_indexing unsafe elt_kind layout b args dbg) (fun addr ->
|
||||
box_complex
|
||||
(Cop(Cload kind, [addr]))
|
||||
(Cop(Cload kind, [Cop(Cadda, [addr; Cconst_int sz])])))
|
||||
| _ ->
|
||||
Cop(Cload (bigarray_word_kind elt_kind),
|
||||
[bigarray_indexing unsafe elt_kind layout b args dbg]))
|
||||
|
||||
let bigarray_set unsafe elt_kind layout b args newval dbg =
|
||||
match elt_kind with
|
||||
Pbigarray_complex32 | Pbigarray_complex64 ->
|
||||
let kind = bigarray_word_kind elt_kind in
|
||||
let sz = bigarray_elt_size elt_kind / 2 in
|
||||
bind "newval" newval (fun newv ->
|
||||
bind "addr" (bigarray_indexing unsafe elt_kind layout b args dbg) (fun addr ->
|
||||
Csequence(
|
||||
Cop(Cstore kind, [addr; complex_re newv]),
|
||||
Cop(Cstore kind,
|
||||
[Cop(Cadda, [addr; Cconst_int sz]); complex_im newv]))))
|
||||
| _ ->
|
||||
Cop(Cstore (bigarray_word_kind elt_kind),
|
||||
[bigarray_indexing unsafe elt_kind layout b args dbg; newval])
|
||||
bind "ba" b (fun b ->
|
||||
match elt_kind with
|
||||
Pbigarray_complex32 | Pbigarray_complex64 ->
|
||||
let kind = bigarray_word_kind elt_kind in
|
||||
let sz = bigarray_elt_size elt_kind / 2 in
|
||||
bind "newval" newval (fun newv ->
|
||||
bind "addr" (bigarray_indexing unsafe elt_kind layout b args dbg) (fun addr ->
|
||||
Csequence(
|
||||
Cop(Cstore kind, [addr; complex_re newv]),
|
||||
Cop(Cstore kind,
|
||||
[Cop(Cadda, [addr; Cconst_int sz]); complex_im newv]))))
|
||||
| _ ->
|
||||
Cop(Cstore (bigarray_word_kind elt_kind),
|
||||
[bigarray_indexing unsafe elt_kind layout b args dbg; newval]))
|
||||
|
||||
(* Simplification of some primitives into C calls *)
|
||||
|
||||
|
|
|
|||
|
|
@ -38,7 +38,7 @@ let rec combine i allocstate =
|
|||
combine i.next (Pending_alloc(i.res.(0), sz)) in
|
||||
(instr_cons (Iop(Ialloc newsz)) i.arg i.res newnext, 0)
|
||||
| Pending_alloc(reg, ofs) ->
|
||||
if ofs + sz < Config.max_young_wosize then begin
|
||||
if ofs + sz < Config.max_young_wosize * Arch.size_addr then begin
|
||||
let (newnext, newsz) =
|
||||
combine i.next (Pending_alloc(reg, ofs + sz)) in
|
||||
(instr_cons (Iop(Iintop_imm(Iadd, ofs))) [| reg |] i.res newnext,
|
||||
|
|
|
|||
|
|
@ -813,7 +813,7 @@ let emit_item = function
|
|||
add_def_symbol s ;
|
||||
`{emit_symbol s} LABEL DWORD\n`
|
||||
| Cdefine_label lbl ->
|
||||
`{emit_label (100000 + lbl)} `
|
||||
`{emit_label (100000 + lbl)} LABEL DWORD\n`
|
||||
| Cint8 n ->
|
||||
` BYTE {emit_int n}\n`
|
||||
| Cint16 n ->
|
||||
|
|
|
|||
|
|
@ -824,3 +824,17 @@ method emit_fundecl f =
|
|||
fun_fast = f.Cmm.fun_fast }
|
||||
|
||||
end
|
||||
|
||||
(* Tail call criterion (estimated). Assumes:
|
||||
- all arguments are of type "int" (always the case for Caml function calls)
|
||||
- one extra argument representing the closure environment (conservative).
|
||||
*)
|
||||
|
||||
let is_tail_call nargs =
|
||||
assert (Reg.dummy.typ = Int);
|
||||
let args = Array.make (nargs + 1) Reg.dummy in
|
||||
let (loc_arg, stack_ofs) = Proc.loc_arguments args in
|
||||
stack_ofs = 0
|
||||
|
||||
let _ =
|
||||
Simplif.is_tail_native_heuristic := is_tail_call
|
||||
|
|
|
|||
|
|
@ -147,44 +147,44 @@ FUNCTION(G(caml_call_gc))
|
|||
STORE_VAR(%r14, caml_exception_pointer)
|
||||
/* Save floating-point registers */
|
||||
subq $(16*8), %rsp
|
||||
movlpd %xmm0, 0*8(%rsp)
|
||||
movlpd %xmm1, 1*8(%rsp)
|
||||
movlpd %xmm2, 2*8(%rsp)
|
||||
movlpd %xmm3, 3*8(%rsp)
|
||||
movlpd %xmm4, 4*8(%rsp)
|
||||
movlpd %xmm5, 5*8(%rsp)
|
||||
movlpd %xmm6, 6*8(%rsp)
|
||||
movlpd %xmm7, 7*8(%rsp)
|
||||
movlpd %xmm8, 8*8(%rsp)
|
||||
movlpd %xmm9, 9*8(%rsp)
|
||||
movlpd %xmm10, 10*8(%rsp)
|
||||
movlpd %xmm11, 11*8(%rsp)
|
||||
movlpd %xmm12, 12*8(%rsp)
|
||||
movlpd %xmm13, 13*8(%rsp)
|
||||
movlpd %xmm14, 14*8(%rsp)
|
||||
movlpd %xmm15, 15*8(%rsp)
|
||||
movsd %xmm0, 0*8(%rsp)
|
||||
movsd %xmm1, 1*8(%rsp)
|
||||
movsd %xmm2, 2*8(%rsp)
|
||||
movsd %xmm3, 3*8(%rsp)
|
||||
movsd %xmm4, 4*8(%rsp)
|
||||
movsd %xmm5, 5*8(%rsp)
|
||||
movsd %xmm6, 6*8(%rsp)
|
||||
movsd %xmm7, 7*8(%rsp)
|
||||
movsd %xmm8, 8*8(%rsp)
|
||||
movsd %xmm9, 9*8(%rsp)
|
||||
movsd %xmm10, 10*8(%rsp)
|
||||
movsd %xmm11, 11*8(%rsp)
|
||||
movsd %xmm12, 12*8(%rsp)
|
||||
movsd %xmm13, 13*8(%rsp)
|
||||
movsd %xmm14, 14*8(%rsp)
|
||||
movsd %xmm15, 15*8(%rsp)
|
||||
/* Call the garbage collector */
|
||||
call GCALL(caml_garbage_collection)
|
||||
/* Restore caml_young_ptr, caml_exception_pointer */
|
||||
LOAD_VAR(caml_young_ptr, %r15)
|
||||
LOAD_VAR(caml_exception_pointer, %r14)
|
||||
/* Restore all regs used by the code generator */
|
||||
movlpd 0*8(%rsp), %xmm0
|
||||
movlpd 1*8(%rsp), %xmm1
|
||||
movlpd 2*8(%rsp), %xmm2
|
||||
movlpd 3*8(%rsp), %xmm3
|
||||
movlpd 4*8(%rsp), %xmm4
|
||||
movlpd 5*8(%rsp), %xmm5
|
||||
movlpd 6*8(%rsp), %xmm6
|
||||
movlpd 7*8(%rsp), %xmm7
|
||||
movlpd 8*8(%rsp), %xmm8
|
||||
movlpd 9*8(%rsp), %xmm9
|
||||
movlpd 10*8(%rsp), %xmm10
|
||||
movlpd 11*8(%rsp), %xmm11
|
||||
movlpd 12*8(%rsp), %xmm12
|
||||
movlpd 13*8(%rsp), %xmm13
|
||||
movlpd 14*8(%rsp), %xmm14
|
||||
movlpd 15*8(%rsp), %xmm15
|
||||
movsd 0*8(%rsp), %xmm0
|
||||
movsd 1*8(%rsp), %xmm1
|
||||
movsd 2*8(%rsp), %xmm2
|
||||
movsd 3*8(%rsp), %xmm3
|
||||
movsd 4*8(%rsp), %xmm4
|
||||
movsd 5*8(%rsp), %xmm5
|
||||
movsd 6*8(%rsp), %xmm6
|
||||
movsd 7*8(%rsp), %xmm7
|
||||
movsd 8*8(%rsp), %xmm8
|
||||
movsd 9*8(%rsp), %xmm9
|
||||
movsd 10*8(%rsp), %xmm10
|
||||
movsd 11*8(%rsp), %xmm11
|
||||
movsd 12*8(%rsp), %xmm12
|
||||
movsd 13*8(%rsp), %xmm13
|
||||
movsd 14*8(%rsp), %xmm14
|
||||
movsd 15*8(%rsp), %xmm15
|
||||
addq $(16*8), %rsp
|
||||
popq %rax
|
||||
popq %rbx
|
||||
|
|
|
|||
|
|
@ -67,43 +67,43 @@ L105:
|
|||
mov caml_gc_regs, rsp
|
||||
; Save floating-point registers
|
||||
sub rsp, 16*8
|
||||
movlpd QWORD PTR [rsp + 0*8], xmm0
|
||||
movlpd QWORD PTR [rsp + 1*8], xmm1
|
||||
movlpd QWORD PTR [rsp + 2*8], xmm2
|
||||
movlpd QWORD PTR [rsp + 3*8], xmm3
|
||||
movlpd QWORD PTR [rsp + 4*8], xmm4
|
||||
movlpd QWORD PTR [rsp + 5*8], xmm5
|
||||
movlpd QWORD PTR [rsp + 6*8], xmm6
|
||||
movlpd QWORD PTR [rsp + 7*8], xmm7
|
||||
movlpd QWORD PTR [rsp + 8*8], xmm8
|
||||
movlpd QWORD PTR [rsp + 9*8], xmm9
|
||||
movlpd QWORD PTR [rsp + 10*8], xmm10
|
||||
movlpd QWORD PTR [rsp + 11*8], xmm11
|
||||
movlpd QWORD PTR [rsp + 12*8], xmm12
|
||||
movlpd QWORD PTR [rsp + 13*8], xmm13
|
||||
movlpd QWORD PTR [rsp + 14*8], xmm14
|
||||
movlpd QWORD PTR [rsp + 15*8], xmm15
|
||||
movsd QWORD PTR [rsp + 0*8], xmm0
|
||||
movsd QWORD PTR [rsp + 1*8], xmm1
|
||||
movsd QWORD PTR [rsp + 2*8], xmm2
|
||||
movsd QWORD PTR [rsp + 3*8], xmm3
|
||||
movsd QWORD PTR [rsp + 4*8], xmm4
|
||||
movsd QWORD PTR [rsp + 5*8], xmm5
|
||||
movsd QWORD PTR [rsp + 6*8], xmm6
|
||||
movsd QWORD PTR [rsp + 7*8], xmm7
|
||||
movsd QWORD PTR [rsp + 8*8], xmm8
|
||||
movsd QWORD PTR [rsp + 9*8], xmm9
|
||||
movsd QWORD PTR [rsp + 10*8], xmm10
|
||||
movsd QWORD PTR [rsp + 11*8], xmm11
|
||||
movsd QWORD PTR [rsp + 12*8], xmm12
|
||||
movsd QWORD PTR [rsp + 13*8], xmm13
|
||||
movsd QWORD PTR [rsp + 14*8], xmm14
|
||||
movsd QWORD PTR [rsp + 15*8], xmm15
|
||||
; Call the garbage collector
|
||||
sub rsp, 32 ; PR#5008: bottom 32 bytes are reserved for callee
|
||||
call caml_garbage_collection
|
||||
add rsp, 32 ; PR#5008
|
||||
; Restore all regs used by the code generator
|
||||
movlpd xmm0, QWORD PTR [rsp + 0*8]
|
||||
movlpd xmm1, QWORD PTR [rsp + 1*8]
|
||||
movlpd xmm2, QWORD PTR [rsp + 2*8]
|
||||
movlpd xmm3, QWORD PTR [rsp + 3*8]
|
||||
movlpd xmm4, QWORD PTR [rsp + 4*8]
|
||||
movlpd xmm5, QWORD PTR [rsp + 5*8]
|
||||
movlpd xmm6, QWORD PTR [rsp + 6*8]
|
||||
movlpd xmm7, QWORD PTR [rsp + 7*8]
|
||||
movlpd xmm8, QWORD PTR [rsp + 8*8]
|
||||
movlpd xmm9, QWORD PTR [rsp + 9*8]
|
||||
movlpd xmm10, QWORD PTR [rsp + 10*8]
|
||||
movlpd xmm11, QWORD PTR [rsp + 11*8]
|
||||
movlpd xmm12, QWORD PTR [rsp + 12*8]
|
||||
movlpd xmm13, QWORD PTR [rsp + 13*8]
|
||||
movlpd xmm14, QWORD PTR [rsp + 14*8]
|
||||
movlpd xmm15, QWORD PTR [rsp + 15*8]
|
||||
movsd xmm0, QWORD PTR [rsp + 0*8]
|
||||
movsd xmm1, QWORD PTR [rsp + 1*8]
|
||||
movsd xmm2, QWORD PTR [rsp + 2*8]
|
||||
movsd xmm3, QWORD PTR [rsp + 3*8]
|
||||
movsd xmm4, QWORD PTR [rsp + 4*8]
|
||||
movsd xmm5, QWORD PTR [rsp + 5*8]
|
||||
movsd xmm6, QWORD PTR [rsp + 6*8]
|
||||
movsd xmm7, QWORD PTR [rsp + 7*8]
|
||||
movsd xmm8, QWORD PTR [rsp + 8*8]
|
||||
movsd xmm9, QWORD PTR [rsp + 9*8]
|
||||
movsd xmm10, QWORD PTR [rsp + 10*8]
|
||||
movsd xmm11, QWORD PTR [rsp + 11*8]
|
||||
movsd xmm12, QWORD PTR [rsp + 12*8]
|
||||
movsd xmm13, QWORD PTR [rsp + 13*8]
|
||||
movsd xmm14, QWORD PTR [rsp + 14*8]
|
||||
movsd xmm15, QWORD PTR [rsp + 15*8]
|
||||
add rsp, 16*8
|
||||
pop rax
|
||||
pop rbx
|
||||
|
|
|
|||
BIN
boot/ocamlc
BIN
boot/ocamlc
Binary file not shown.
BIN
boot/ocamldep
BIN
boot/ocamldep
Binary file not shown.
BIN
boot/ocamllex
BIN
boot/ocamllex
Binary file not shown.
|
|
@ -2,7 +2,7 @@
|
|||
# $Id$
|
||||
cd `dirname $0`/..
|
||||
set -ex
|
||||
TAGLINE='true: -use_stdlib'
|
||||
TAG_LINE='true: -use_stdlib'
|
||||
./boot/ocamlrun boot/myocamlbuild.boot \
|
||||
-tag-line "$TAG_LINE" \
|
||||
boot/stdlib.cma boot/std_exit.cmo
|
||||
|
|
|
|||
|
|
@ -95,7 +95,8 @@
|
|||
Then "Generate Camlp4Ast.ml" and build.
|
||||
|
||||
We get a single warning in Camlp4/Struct/Camlp4Ast2OCamlAst.ml but
|
||||
don't fix it now.
|
||||
don't fix it now. Notice that you may need to disable '-warn-error'
|
||||
in order to be able to successfully compile, despite of the warning.
|
||||
|
||||
Then I hacked the camlp4/boot/camlp4boot.ml to generate:
|
||||
Ast.ExOpI(_loc, i, e)
|
||||
|
|
|
|||
|
|
@ -8,8 +8,7 @@
|
|||
# #
|
||||
# Copyright 2008 Institut National de Recherche en Informatique et #
|
||||
# en Automatique. All rights reserved. This file is distributed #
|
||||
# under the terms of the GNU Library General Public License, with #
|
||||
# the special exception on linking described in file LICENSE. #
|
||||
# under the terms of the Q Public License version 1.0. #
|
||||
# #
|
||||
#########################################################################
|
||||
|
||||
|
|
|
|||
|
|
@ -8,8 +8,7 @@
|
|||
# #
|
||||
# Copyright 2008 Institut National de Recherche en Informatique et #
|
||||
# en Automatique. All rights reserved. This file is distributed #
|
||||
# under the terms of the GNU Library General Public License, with #
|
||||
# the special exception on linking described in file LICENSE. #
|
||||
# under the terms of the Q Public License version 1.0. #
|
||||
# #
|
||||
#########################################################################
|
||||
|
||||
|
|
|
|||
|
|
@ -8,8 +8,7 @@
|
|||
# #
|
||||
# Copyright 2008 Institut National de Recherche en Informatique et #
|
||||
# en Automatique. All rights reserved. This file is distributed #
|
||||
# under the terms of the GNU Library General Public License, with #
|
||||
# the special exception on linking described in file LICENSE. #
|
||||
# under the terms of the Q Public License version 1.0. #
|
||||
# #
|
||||
#########################################################################
|
||||
|
||||
|
|
@ -45,3 +44,7 @@ cp _build/myocamlbuild boot/myocamlbuild.native
|
|||
$OCAMLC_NATIVE $TOPLEVEL $OTHERLIBS_BYTE $OTHERLIBS_NATIVE $OCAMLLEX_BYTE \
|
||||
$OCAMLLEX_NATIVE $TOOLS_BYTE $TOOLS_NATIVE $DEBUGGER \
|
||||
$OCAMLDOC_BYTE $OCAMLDOC_NATIVE $OCAMLBUILD_BYTE $CAMLP4_BYTE $CAMLP4_NATIVE
|
||||
|
||||
cd tools
|
||||
make objinfo_helper
|
||||
cd ..
|
||||
|
|
|
|||
|
|
@ -264,6 +264,8 @@ installbin lex/ocamllex.opt$EXE $BINDIR/ocamllex.opt$EXE
|
|||
installbin tools/ocamldep.native$EXE $BINDIR/ocamldep.opt$EXE
|
||||
|
||||
echo "Installing some tools..."
|
||||
installbin tools/objinfo.byte$EXE $BINDIR/ocamlobjinfo$EXE
|
||||
installbin ../tools/objinfo_helper$EXE $LIBDIR/objinfo_helper$EXE
|
||||
installbin tools/ocamlcp.byte$EXE $BINDIR/ocamlcp$EXE
|
||||
installbin tools/ocamldep.byte$EXE $BINDIR/ocamldep$EXE
|
||||
installbin tools/ocamlmklib.byte$EXE $BINDIR/ocamlmklib$EXE
|
||||
|
|
|
|||
|
|
@ -8,8 +8,7 @@
|
|||
# #
|
||||
# Copyright 2008 Institut National de Recherche en Informatique et #
|
||||
# en Automatique. All rights reserved. This file is distributed #
|
||||
# under the terms of the GNU Library General Public License, with #
|
||||
# the special exception on linking described in file LICENSE. #
|
||||
# under the terms of the Q Public License version 1.0. #
|
||||
# #
|
||||
#########################################################################
|
||||
|
||||
|
|
|
|||
|
|
@ -8,8 +8,7 @@
|
|||
# #
|
||||
# Copyright 2008 Institut National de Recherche en Informatique et #
|
||||
# en Automatique. All rights reserved. This file is distributed #
|
||||
# under the terms of the GNU Library General Public License, with #
|
||||
# the special exception on linking described in file LICENSE. #
|
||||
# under the terms of the Q Public License version 1.0. #
|
||||
# #
|
||||
#########################################################################
|
||||
|
||||
|
|
|
|||
|
|
@ -8,8 +8,7 @@
|
|||
# #
|
||||
# Copyright 2008 Institut National de Recherche en Informatique et #
|
||||
# en Automatique. All rights reserved. This file is distributed #
|
||||
# under the terms of the GNU Library General Public License, with #
|
||||
# the special exception on linking described in file LICENSE. #
|
||||
# under the terms of the Q Public License version 1.0. #
|
||||
# #
|
||||
#########################################################################
|
||||
|
||||
|
|
|
|||
|
|
@ -8,8 +8,7 @@
|
|||
# #
|
||||
# Copyright 2008 Institut National de Recherche en Informatique et #
|
||||
# en Automatique. All rights reserved. This file is distributed #
|
||||
# under the terms of the GNU Library General Public License, with #
|
||||
# the special exception on linking described in file LICENSE. #
|
||||
# under the terms of the Q Public License version 1.0. #
|
||||
# #
|
||||
#########################################################################
|
||||
|
||||
|
|
|
|||
|
|
@ -29,7 +29,8 @@ OCAMLBUILD_BYTE="ocamlbuild/ocamlbuildlib.cma \
|
|||
ocamlbuild/ocamlbuild.byte$EXE \
|
||||
ocamlbuild/ocamlbuildlight.byte$EXE"
|
||||
TOPLEVEL=ocaml$EXE
|
||||
TOOLS_BYTE="tools/ocamldep.byte$EXE tools/profiling.cmo \
|
||||
TOOLS_BYTE="tools/objinfo.byte$EXE \
|
||||
tools/ocamldep.byte$EXE tools/profiling.cmo \
|
||||
tools/ocamlprof.byte$EXE tools/ocamlcp.byte$EXE \
|
||||
tools/ocamlmktop.byte$EXE tools/ocamlmklib$EXE \
|
||||
tools/scrapelabels.byte tools/addlabels.byte \
|
||||
|
|
|
|||
|
|
@ -8,8 +8,7 @@
|
|||
# #
|
||||
# Copyright 2008 Institut National de Recherche en Informatique et #
|
||||
# en Automatique. All rights reserved. This file is distributed #
|
||||
# under the terms of the GNU Library General Public License, with #
|
||||
# the special exception on linking described in file LICENSE. #
|
||||
# under the terms of the Q Public License version 1.0. #
|
||||
# #
|
||||
#########################################################################
|
||||
|
||||
|
|
|
|||
|
|
@ -413,12 +413,10 @@ let rec comp_expr env exp sz cont =
|
|||
| Lapply(func, args, loc) ->
|
||||
let nargs = List.length args in
|
||||
if is_tailcall cont then begin
|
||||
Stypes.record (Stypes.An_call (loc, Annot.Tail));
|
||||
comp_args env args sz
|
||||
(Kpush :: comp_expr env func (sz + nargs)
|
||||
(Kappterm(nargs, sz + nargs) :: discard_dead_code cont))
|
||||
end else begin
|
||||
Stypes.record (Stypes.An_call (loc, Annot.Stack));
|
||||
if nargs < 4 then
|
||||
comp_args env args sz
|
||||
(Kpush :: comp_expr env func (sz + nargs) (Kapply nargs :: cont))
|
||||
|
|
@ -430,7 +428,7 @@ let rec comp_expr env exp sz cont =
|
|||
(Kapply nargs :: cont1))
|
||||
end
|
||||
end
|
||||
| Lsend(kind, met, obj, args) ->
|
||||
| Lsend(kind, met, obj, args, _) ->
|
||||
let args = if kind = Cached then List.tl args else args in
|
||||
let nargs = List.length args + 1 in
|
||||
let getmethod, args' =
|
||||
|
|
@ -746,9 +744,9 @@ let rec comp_expr env exp sz cont =
|
|||
| Lev_after ty ->
|
||||
let info =
|
||||
match lam with
|
||||
Lapply(_, args, _) -> Event_return (List.length args)
|
||||
| Lsend(_, _, _, args) -> Event_return (List.length args + 1)
|
||||
| _ -> Event_other
|
||||
Lapply(_, args, _) -> Event_return (List.length args)
|
||||
| Lsend(_, _, _, args, _) -> Event_return (List.length args + 1)
|
||||
| _ -> Event_other
|
||||
in
|
||||
let ev = event (Event_after ty) info in
|
||||
let cont1 = add_event ev cont in
|
||||
|
|
|
|||
|
|
@ -407,15 +407,15 @@ let link_bytecode_as_c tolink outfile =
|
|||
begin try
|
||||
(* The bytecode *)
|
||||
output_string outchan "\
|
||||
#ifdef __cplusplus\n\
|
||||
extern \"C\" {\n\
|
||||
#endif\n\
|
||||
#include <caml/mlvalues.h>\n\
|
||||
CAMLextern void caml_startup_code(\n\
|
||||
code_t code, asize_t code_size,\n\
|
||||
char *data, asize_t data_size,\n\
|
||||
char *section_table, asize_t section_table_size,\n\
|
||||
char **argv);\n";
|
||||
#ifdef __cplusplus\
|
||||
\nextern \"C\" {\
|
||||
\n#endif\
|
||||
\n#include <caml/mlvalues.h>\
|
||||
\nCAMLextern void caml_startup_code(\
|
||||
\n code_t code, asize_t code_size,\
|
||||
\n char *data, asize_t data_size,\
|
||||
\n char *section_table, asize_t section_table_size,\
|
||||
\n char **argv);\n";
|
||||
output_string outchan "static int caml_code[] = {\n";
|
||||
Symtable.init();
|
||||
Consistbl.clear crc_interfaces;
|
||||
|
|
@ -444,17 +444,17 @@ CAMLextern void caml_startup_code(\n\
|
|||
(* The table of primitives *)
|
||||
Symtable.output_primitive_table outchan;
|
||||
(* The entry point *)
|
||||
output_string outchan "\n\
|
||||
void caml_startup(char ** argv)\n\
|
||||
{\n\
|
||||
caml_startup_code(caml_code, sizeof(caml_code),\n\
|
||||
caml_data, sizeof(caml_data),\n\
|
||||
caml_sections, sizeof(caml_sections),\n\
|
||||
argv);\n\
|
||||
}\n\
|
||||
#ifdef __cplusplus\n\
|
||||
}\n\
|
||||
#endif\n";
|
||||
output_string outchan "\
|
||||
\nvoid caml_startup(char ** argv)\
|
||||
\n{\
|
||||
\n caml_startup_code(caml_code, sizeof(caml_code),\
|
||||
\n caml_data, sizeof(caml_data),\
|
||||
\n caml_sections, sizeof(caml_sections),\
|
||||
\n argv);\
|
||||
\n}\
|
||||
\n#ifdef __cplusplus\
|
||||
\n}\
|
||||
\n#endif\n";
|
||||
close_out outchan
|
||||
with x ->
|
||||
close_out outchan;
|
||||
|
|
|
|||
|
|
@ -39,7 +39,7 @@ let force_link = ref false
|
|||
SETGLOBAL relocations that correspond to one of the units being
|
||||
consolidated. *)
|
||||
|
||||
let rename_relocation objfile mapping defined base (rel, ofs) =
|
||||
let rename_relocation packagename objfile mapping defined base (rel, ofs) =
|
||||
let rel' =
|
||||
match rel with
|
||||
Reloc_getglobal id ->
|
||||
|
|
@ -49,7 +49,14 @@ let rename_relocation objfile mapping defined base (rel, ofs) =
|
|||
then Reloc_getglobal id'
|
||||
else raise(Error(Forward_reference(objfile, id)))
|
||||
with Not_found ->
|
||||
rel
|
||||
(* PR#5276: unique-ize dotted global names, which appear
|
||||
if one of the units being consolidated is itself a packed
|
||||
module. *)
|
||||
let name = Ident.name id in
|
||||
if String.contains name '.' then
|
||||
Reloc_getglobal (Ident.create_persistent (packagename ^ "." ^ name))
|
||||
else
|
||||
rel
|
||||
end
|
||||
| Reloc_setglobal id ->
|
||||
begin try
|
||||
|
|
@ -58,7 +65,12 @@ let rename_relocation objfile mapping defined base (rel, ofs) =
|
|||
then raise(Error(Multiple_definition(objfile, id)))
|
||||
else Reloc_setglobal id'
|
||||
with Not_found ->
|
||||
rel
|
||||
(* PR#5276, as above *)
|
||||
let name = Ident.name id in
|
||||
if String.contains name '.' then
|
||||
Reloc_setglobal (Ident.create_persistent (packagename ^ "." ^ name))
|
||||
else
|
||||
rel
|
||||
end
|
||||
| _ ->
|
||||
rel in
|
||||
|
|
@ -112,12 +124,12 @@ let read_member_info file =
|
|||
Accumulate relocs, debug info, etc.
|
||||
Return size of bytecode. *)
|
||||
|
||||
let rename_append_bytecode oc mapping defined ofs prefix subst objfile compunit =
|
||||
let rename_append_bytecode packagename oc mapping defined ofs prefix subst objfile compunit =
|
||||
let ic = open_in_bin objfile in
|
||||
try
|
||||
Bytelink.check_consistency objfile compunit;
|
||||
List.iter
|
||||
(rename_relocation objfile mapping defined ofs)
|
||||
(rename_relocation packagename objfile mapping defined ofs)
|
||||
compunit.cu_reloc;
|
||||
primitives := compunit.cu_primitives @ !primitives;
|
||||
if compunit.cu_force_link then force_link := true;
|
||||
|
|
@ -136,20 +148,20 @@ let rename_append_bytecode oc mapping defined ofs prefix subst objfile compunit
|
|||
(* Same, for a list of .cmo and .cmi files.
|
||||
Return total size of bytecode. *)
|
||||
|
||||
let rec rename_append_bytecode_list oc mapping defined ofs prefix subst = function
|
||||
let rec rename_append_bytecode_list packagename oc mapping defined ofs prefix subst = function
|
||||
[] ->
|
||||
ofs
|
||||
| m :: rem ->
|
||||
match m.pm_kind with
|
||||
| PM_intf ->
|
||||
rename_append_bytecode_list oc mapping defined ofs prefix subst rem
|
||||
rename_append_bytecode_list packagename oc mapping defined ofs prefix subst rem
|
||||
| PM_impl compunit ->
|
||||
let size =
|
||||
rename_append_bytecode oc mapping defined ofs prefix subst
|
||||
rename_append_bytecode packagename oc mapping defined ofs prefix subst
|
||||
m.pm_file compunit in
|
||||
let id = Ident.create_persistent m.pm_name in
|
||||
let root = Path.Pident (Ident.create_persistent prefix) in
|
||||
rename_append_bytecode_list
|
||||
rename_append_bytecode_list packagename
|
||||
oc mapping (id :: defined)
|
||||
(ofs + size) prefix (Subst.add_module id (Path.Pdot (root, Ident.name id, Path.nopos)) subst) rem
|
||||
|
||||
|
|
@ -191,7 +203,7 @@ let package_object_files files targetfile targetname coercion =
|
|||
let pos_depl = pos_out oc in
|
||||
output_binary_int oc 0;
|
||||
let pos_code = pos_out oc in
|
||||
let ofs = rename_append_bytecode_list oc mapping [] 0 targetname Subst.identity members in
|
||||
let ofs = rename_append_bytecode_list targetname oc mapping [] 0 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
|
||||
|
|
|
|||
|
|
@ -140,7 +140,7 @@ type lambda =
|
|||
| Lwhile of lambda * lambda
|
||||
| Lfor of Ident.t * lambda * lambda * direction_flag * lambda
|
||||
| Lassign of Ident.t * lambda
|
||||
| Lsend of meth_kind * lambda * lambda * lambda list
|
||||
| Lsend of meth_kind * lambda * lambda * lambda list * Location.t
|
||||
| Levent of lambda * lambda_event
|
||||
| Lifused of Ident.t * lambda
|
||||
|
||||
|
|
@ -201,7 +201,7 @@ let rec same l1 l2 =
|
|||
same b1 b2 && df1 = df2 && same c1 c2
|
||||
| Lassign(id1, a1), Lassign(id2, a2) ->
|
||||
Ident.same id1 id2 && same a1 a2
|
||||
| Lsend(k1, a1, b1, cl1), Lsend(k2, a2, b2, cl2) ->
|
||||
| Lsend(k1, a1, b1, cl1, _), Lsend(k2, a2, b2, cl2, _) ->
|
||||
k1 = k2 && same a1 a2 && same b1 b2 && samelist same cl1 cl2
|
||||
| Levent(a1, ev1), Levent(a2, ev2) ->
|
||||
same a1 a2 && ev1.lev_loc = ev2.lev_loc
|
||||
|
|
@ -277,7 +277,7 @@ let rec iter f = function
|
|||
f e1; f e2; f e3
|
||||
| Lassign(id, e) ->
|
||||
f e
|
||||
| Lsend (k, met, obj, args) ->
|
||||
| Lsend (k, met, obj, args, _) ->
|
||||
List.iter f (met::obj::args)
|
||||
| Levent (lam, evt) ->
|
||||
f lam
|
||||
|
|
@ -320,7 +320,7 @@ let free_variables l =
|
|||
free_ids (function Lvar id -> [id] | _ -> []) l
|
||||
|
||||
let free_methods l =
|
||||
free_ids (function Lsend(Self, Lvar meth, obj, _) -> [meth] | _ -> []) l
|
||||
free_ids (function Lsend(Self, Lvar meth, obj, _, _) -> [meth] | _ -> []) l
|
||||
|
||||
(* Check if an action has a "when" guard *)
|
||||
let raise_count = ref 0
|
||||
|
|
@ -398,8 +398,8 @@ let subst_lambda s lam =
|
|||
| Lwhile(e1, e2) -> Lwhile(subst e1, subst e2)
|
||||
| Lfor(v, e1, e2, dir, e3) -> Lfor(v, subst e1, subst e2, dir, subst e3)
|
||||
| Lassign(id, e) -> Lassign(id, subst e)
|
||||
| Lsend (k, met, obj, args) ->
|
||||
Lsend (k, subst met, subst obj, List.map subst args)
|
||||
| Lsend (k, met, obj, args, loc) ->
|
||||
Lsend (k, subst met, subst obj, List.map subst args, loc)
|
||||
| Levent (lam, evt) -> Levent (subst lam, evt)
|
||||
| Lifused (v, e) -> Lifused (v, subst e)
|
||||
and subst_decl (id, exp) = (id, subst exp)
|
||||
|
|
|
|||
|
|
@ -149,7 +149,7 @@ type lambda =
|
|||
| Lwhile of lambda * lambda
|
||||
| Lfor of Ident.t * lambda * lambda * direction_flag * lambda
|
||||
| Lassign of Ident.t * lambda
|
||||
| Lsend of meth_kind * lambda * lambda * lambda list
|
||||
| Lsend of meth_kind * lambda * lambda * lambda list * Location.t
|
||||
| Levent of lambda * lambda_event
|
||||
| Lifused of Ident.t * lambda
|
||||
|
||||
|
|
|
|||
|
|
@ -285,7 +285,7 @@ let rec lam ppf = function
|
|||
lam hi lam body
|
||||
| Lassign(id, expr) ->
|
||||
fprintf ppf "@[<2>(assign@ %a@ %a)@]" Ident.print id lam expr
|
||||
| Lsend (k, met, obj, largs) ->
|
||||
| Lsend (k, met, obj, largs, _) ->
|
||||
let args ppf largs =
|
||||
List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in
|
||||
let kind =
|
||||
|
|
|
|||
|
|
@ -75,9 +75,9 @@ let rec eliminate_ref id = function
|
|||
dir, eliminate_ref id e3)
|
||||
| Lassign(v, e) ->
|
||||
Lassign(v, eliminate_ref id e)
|
||||
| Lsend(k, m, o, el) ->
|
||||
| Lsend(k, m, o, el, loc) ->
|
||||
Lsend(k, eliminate_ref id m, eliminate_ref id o,
|
||||
List.map (eliminate_ref id) el)
|
||||
List.map (eliminate_ref id) el, loc)
|
||||
| Levent(l, ev) ->
|
||||
Levent(eliminate_ref id l, ev)
|
||||
| Lifused(v, e) ->
|
||||
|
|
@ -144,7 +144,7 @@ let simplify_exits lam =
|
|||
(* Lalias-bound variables are never assigned, so don't increase
|
||||
v's refcount *)
|
||||
count l
|
||||
| Lsend(k, m, o, ll) -> List.iter count (m::o::ll)
|
||||
| Lsend(k, m, o, ll, _) -> List.iter count (m::o::ll)
|
||||
| Levent(l, _) -> count l
|
||||
| Lifused(v, l) -> count l
|
||||
|
||||
|
|
@ -250,7 +250,7 @@ let simplify_exits lam =
|
|||
| Lfor(v, l1, l2, dir, l3) ->
|
||||
Lfor(v, simplif l1, simplif l2, dir, simplif l3)
|
||||
| Lassign(v, l) -> Lassign(v, simplif l)
|
||||
| Lsend(k, m, o, ll) -> Lsend(k, simplif m, simplif o, List.map simplif ll)
|
||||
| Lsend(k, m, o, ll, loc) -> Lsend(k, simplif m, simplif o, List.map simplif ll, loc)
|
||||
| Levent(l, ev) -> Levent(simplif l, ev)
|
||||
| Lifused(v, l) -> Lifused (v,simplif l)
|
||||
in
|
||||
|
|
@ -336,7 +336,7 @@ let simplify_lets lam =
|
|||
(* Lalias-bound variables are never assigned, so don't increase
|
||||
v's refcount *)
|
||||
count bv l
|
||||
| Lsend(_, m, o, ll) -> List.iter (count bv) (m::o::ll)
|
||||
| Lsend(_, m, o, ll, _) -> List.iter (count bv) (m::o::ll)
|
||||
| Levent(l, _) -> count bv l
|
||||
| Lifused(v, l) ->
|
||||
if count_var v > 0 then count bv l
|
||||
|
|
@ -434,11 +434,93 @@ let simplify_lets lam =
|
|||
| Lfor(v, l1, l2, dir, l3) ->
|
||||
Lfor(v, simplif l1, simplif l2, dir, simplif l3)
|
||||
| Lassign(v, l) -> Lassign(v, simplif l)
|
||||
| Lsend(k, m, o, ll) -> Lsend(k, simplif m, simplif o, List.map simplif ll)
|
||||
| Lsend(k, m, o, ll, loc) -> Lsend(k, simplif m, simplif o, List.map simplif ll, loc)
|
||||
| Levent(l, ev) -> Levent(simplif l, ev)
|
||||
| Lifused(v, l) ->
|
||||
if count_var v > 0 then simplif l else lambda_unit
|
||||
in
|
||||
simplif lam
|
||||
|
||||
let simplify_lambda lam = simplify_lets (simplify_exits lam)
|
||||
(* Tail call info in annotation files *)
|
||||
|
||||
let is_tail_native_heuristic : (int -> bool) ref =
|
||||
ref (fun n -> true)
|
||||
|
||||
let rec emit_tail_infos is_tail lambda =
|
||||
let call_kind args =
|
||||
if is_tail
|
||||
&& ((not !Clflags.native_code)
|
||||
|| (!is_tail_native_heuristic (List.length args)))
|
||||
then Annot.Tail
|
||||
else Annot.Stack in
|
||||
match lambda with
|
||||
| Lvar _ -> ()
|
||||
| Lconst _ -> ()
|
||||
| Lapply (func, l, loc) ->
|
||||
list_emit_tail_infos false l;
|
||||
Stypes.record (Stypes.An_call (loc, call_kind l))
|
||||
| Lfunction (_, _, lam) ->
|
||||
emit_tail_infos true lam
|
||||
| Llet (_, _, lam, body) ->
|
||||
emit_tail_infos false lam;
|
||||
emit_tail_infos is_tail body
|
||||
| Lletrec (bindings, body) ->
|
||||
List.iter (fun (_, lam) -> emit_tail_infos false lam) bindings;
|
||||
emit_tail_infos is_tail body
|
||||
| Lprim (Pidentity, [arg]) ->
|
||||
emit_tail_infos is_tail arg
|
||||
| Lprim (Psequand, [arg1; arg2])
|
||||
| Lprim (Psequor, [arg1; arg2]) ->
|
||||
emit_tail_infos false arg1;
|
||||
emit_tail_infos is_tail arg2
|
||||
| Lprim (_, l) ->
|
||||
list_emit_tail_infos false l
|
||||
| Lswitch (lam, sw) ->
|
||||
emit_tail_infos false lam;
|
||||
list_emit_tail_infos_fun snd is_tail sw.sw_consts;
|
||||
list_emit_tail_infos_fun snd is_tail sw.sw_blocks
|
||||
| Lstaticraise (_, l) ->
|
||||
list_emit_tail_infos false l
|
||||
| Lstaticcatch (body, _, handler) ->
|
||||
emit_tail_infos is_tail body;
|
||||
emit_tail_infos is_tail handler
|
||||
| Ltrywith (body, _, handler) ->
|
||||
emit_tail_infos false body;
|
||||
emit_tail_infos is_tail handler
|
||||
| Lifthenelse (cond, ifso, ifno) ->
|
||||
emit_tail_infos false cond;
|
||||
emit_tail_infos is_tail ifso;
|
||||
emit_tail_infos is_tail ifno
|
||||
| Lsequence (lam1, lam2) ->
|
||||
emit_tail_infos false lam1;
|
||||
emit_tail_infos is_tail lam2
|
||||
| Lwhile (cond, body) ->
|
||||
emit_tail_infos false cond;
|
||||
emit_tail_infos false body
|
||||
| Lfor (_, low, high, _, body) ->
|
||||
emit_tail_infos false low;
|
||||
emit_tail_infos false high;
|
||||
emit_tail_infos false body
|
||||
| Lassign (_, lam) ->
|
||||
emit_tail_infos false lam
|
||||
| Lsend (_, meth, obj, args, loc) ->
|
||||
emit_tail_infos false meth;
|
||||
emit_tail_infos false obj;
|
||||
list_emit_tail_infos false args;
|
||||
Stypes.record (Stypes.An_call (loc, call_kind (obj :: args)))
|
||||
| Levent (lam, _) ->
|
||||
emit_tail_infos is_tail lam
|
||||
| Lifused (_, lam) ->
|
||||
emit_tail_infos is_tail lam
|
||||
and list_emit_tail_infos_fun f is_tail =
|
||||
List.iter (fun x -> emit_tail_infos is_tail (f x))
|
||||
and list_emit_tail_infos is_tail =
|
||||
List.iter (emit_tail_infos is_tail)
|
||||
|
||||
(* The entry point:
|
||||
simplification + emission of tailcall annotations, if needed. *)
|
||||
|
||||
let simplify_lambda lam =
|
||||
let res = simplify_lets (simplify_exits lam) in
|
||||
if !Clflags.annotations then emit_tail_infos true res;
|
||||
res
|
||||
|
|
|
|||
|
|
@ -12,8 +12,15 @@
|
|||
|
||||
(* $Id$ *)
|
||||
|
||||
(* Elimination of useless Llet(Alias) bindings *)
|
||||
(* Elimination of useless Llet(Alias) bindings.
|
||||
Transformation of let-bound references into variables.
|
||||
Simplification over staticraise/staticcatch constructs.
|
||||
Generation of tail-call annotations if -annot is set. *)
|
||||
|
||||
open Lambda
|
||||
|
||||
val simplify_lambda: lambda -> lambda
|
||||
|
||||
(* To be filled by asmcomp/selectgen.ml *)
|
||||
val is_tail_native_heuristic: (int -> bool) ref
|
||||
(* # arguments -> can tailcall *)
|
||||
|
|
|
|||
|
|
@ -495,7 +495,7 @@ let rec builtin_meths self env env2 body =
|
|||
"var", [Lvar n]
|
||||
| Lprim(Pfield n, [Lvar e]) when Ident.same e env ->
|
||||
"env", [Lvar env2; Lconst(Const_pointer n)]
|
||||
| Lsend(Self, met, Lvar s, []) when List.mem s self ->
|
||||
| Lsend(Self, met, Lvar s, [], _) when List.mem s self ->
|
||||
"meth", [met]
|
||||
| _ -> raise Not_found
|
||||
in
|
||||
|
|
@ -510,15 +510,15 @@ let rec builtin_meths self env env2 body =
|
|||
| Lapply(f, [p; arg], _) when const_path f && const_path p ->
|
||||
let s, args = conv arg in
|
||||
("app_const_"^s, f :: p :: args)
|
||||
| Lsend(Self, Lvar n, Lvar s, [arg]) when List.mem s self ->
|
||||
| Lsend(Self, Lvar n, Lvar s, [arg], _) when List.mem s self ->
|
||||
let s, args = conv arg in
|
||||
("meth_app_"^s, Lvar n :: args)
|
||||
| Lsend(Self, met, Lvar s, []) when List.mem s self ->
|
||||
| Lsend(Self, met, Lvar s, [], _) when List.mem s self ->
|
||||
("get_meth", [met])
|
||||
| Lsend(Public, met, arg, []) ->
|
||||
| Lsend(Public, met, arg, [], _) ->
|
||||
let s, args = conv arg in
|
||||
("send_"^s, met :: args)
|
||||
| Lsend(Cached, met, arg, [_;_]) ->
|
||||
| Lsend(Cached, met, arg, [_;_], _) ->
|
||||
let s, args = conv arg in
|
||||
("send_"^s, met :: args)
|
||||
| Lfunction (Curried, [x], body) ->
|
||||
|
|
|
|||
|
|
@ -571,12 +571,12 @@ and transl_exp0 e =
|
|||
if public_send || p.prim_name = "%sendself" then
|
||||
let kind = if public_send then Public else Self in
|
||||
let obj = Ident.create "obj" and meth = Ident.create "meth" in
|
||||
Lfunction(Curried, [obj; meth], Lsend(kind, Lvar meth, Lvar obj, []))
|
||||
Lfunction(Curried, [obj; meth], Lsend(kind, Lvar meth, Lvar obj, [], e.exp_loc))
|
||||
else if p.prim_name = "%sendcache" then
|
||||
let obj = Ident.create "obj" and meth = Ident.create "meth" in
|
||||
let cache = Ident.create "cache" and pos = Ident.create "pos" in
|
||||
Lfunction(Curried, [obj; meth; cache; pos],
|
||||
Lsend(Cached, Lvar meth, Lvar obj, [Lvar cache; Lvar pos]))
|
||||
Lsend(Cached, Lvar meth, Lvar obj, [Lvar cache; Lvar pos], e.exp_loc))
|
||||
else
|
||||
transl_primitive p
|
||||
| Texp_ident(path, {val_kind = Val_anc _}) ->
|
||||
|
|
@ -614,10 +614,10 @@ and transl_exp0 e =
|
|||
if public_send || p.prim_name = "%sendself" then
|
||||
let kind = if public_send then Public else Self in
|
||||
let obj = List.hd argl in
|
||||
wrap (Lsend (kind, List.nth argl 1, obj, []))
|
||||
wrap (Lsend (kind, List.nth argl 1, obj, [], e.exp_loc))
|
||||
else if p.prim_name = "%sendcache" then
|
||||
match argl with [obj; meth; cache; pos] ->
|
||||
wrap (Lsend(Cached, meth, obj, [cache; pos]))
|
||||
wrap (Lsend(Cached, meth, obj, [cache; pos], e.exp_loc))
|
||||
| _ -> assert false
|
||||
else begin
|
||||
let prim = transl_prim p args in
|
||||
|
|
@ -737,11 +737,11 @@ and transl_exp0 e =
|
|||
let obj = transl_exp expr in
|
||||
let lam =
|
||||
match met with
|
||||
Tmeth_val id -> Lsend (Self, Lvar id, obj, [])
|
||||
Tmeth_val id -> Lsend (Self, Lvar id, obj, [], e.exp_loc)
|
||||
| Tmeth_name nm ->
|
||||
let (tag, cache) = Translobj.meth obj nm in
|
||||
let kind = if cache = [] then Public else Cached in
|
||||
Lsend (kind, tag, obj, cache)
|
||||
Lsend (kind, tag, obj, cache, e.exp_loc)
|
||||
in
|
||||
event_after e lam
|
||||
| Texp_new (cl, _) ->
|
||||
|
|
@ -840,10 +840,10 @@ and transl_tupled_cases patl_expr_list =
|
|||
and transl_apply lam sargs loc =
|
||||
let lapply funct args =
|
||||
match funct with
|
||||
Lsend(k, lmet, lobj, largs) ->
|
||||
Lsend(k, lmet, lobj, largs @ args)
|
||||
| Levent(Lsend(k, lmet, lobj, largs), _) ->
|
||||
Lsend(k, lmet, lobj, largs @ args)
|
||||
Lsend(k, lmet, lobj, largs, loc) ->
|
||||
Lsend(k, lmet, lobj, largs @ args, loc)
|
||||
| Levent(Lsend(k, lmet, lobj, largs, loc), _) ->
|
||||
Lsend(k, lmet, lobj, largs @ args, loc)
|
||||
| Lapply(lexp, largs, _) ->
|
||||
Lapply(lexp, largs @ args, loc)
|
||||
| lexp ->
|
||||
|
|
|
|||
|
|
@ -104,18 +104,44 @@ static intnat compare_val(value v1, value v2, int total)
|
|||
if (Is_long(v2))
|
||||
return Long_val(v1) - Long_val(v2);
|
||||
/* Subtraction above cannot overflow and cannot result in UNORDERED */
|
||||
if (Is_in_value_area(v2) &&
|
||||
Tag_val(v2) == Forward_tag) {
|
||||
v2 = Forward_val(v2);
|
||||
continue;
|
||||
if (Is_in_value_area(v2)) {
|
||||
switch (Tag_val(v2)) {
|
||||
case Forward_tag:
|
||||
v2 = Forward_val(v2);
|
||||
continue;
|
||||
case Custom_tag: {
|
||||
int res;
|
||||
int (*compare)(value v1, value v2) = Custom_ops_val(v2)->compare_ext;
|
||||
if (compare == NULL) break; /* for backward compatibility */
|
||||
caml_compare_unordered = 0;
|
||||
res = compare(v1, v2);
|
||||
if (caml_compare_unordered && !total) return UNORDERED;
|
||||
if (res != 0) return res;
|
||||
goto next_item;
|
||||
}
|
||||
default: /*fallthrough*/;
|
||||
}
|
||||
}
|
||||
return LESS; /* v1 long < v2 block */
|
||||
}
|
||||
if (Is_long(v2)) {
|
||||
if (Is_in_value_area(v1) &&
|
||||
Tag_val(v1) == Forward_tag) {
|
||||
v1 = Forward_val(v1);
|
||||
continue;
|
||||
if (Is_in_value_area(v1)) {
|
||||
switch (Tag_val(v1)) {
|
||||
case Forward_tag:
|
||||
v1 = Forward_val(v1);
|
||||
continue;
|
||||
case Custom_tag: {
|
||||
int res;
|
||||
int (*compare)(value v1, value v2) = Custom_ops_val(v1)->compare_ext;
|
||||
if (compare == NULL) break; /* for backward compatibility */
|
||||
caml_compare_unordered = 0;
|
||||
res = compare(v1, v2);
|
||||
if (caml_compare_unordered && !total) return UNORDERED;
|
||||
if (res != 0) return res;
|
||||
goto next_item;
|
||||
}
|
||||
default: /*fallthrough*/;
|
||||
}
|
||||
}
|
||||
return GREATER; /* v1 block > v2 long */
|
||||
}
|
||||
|
|
@ -134,17 +160,14 @@ static intnat compare_val(value v1, value v2, int total)
|
|||
if (t1 != t2) return (intnat)t1 - (intnat)t2;
|
||||
switch(t1) {
|
||||
case String_tag: {
|
||||
mlsize_t len1, len2, len;
|
||||
unsigned char * p1, * p2;
|
||||
mlsize_t len1, len2;
|
||||
int res;
|
||||
if (v1 == v2) break;
|
||||
len1 = caml_string_length(v1);
|
||||
len2 = caml_string_length(v2);
|
||||
for (len = (len1 <= len2 ? len1 : len2),
|
||||
p1 = (unsigned char *) String_val(v1),
|
||||
p2 = (unsigned char *) String_val(v2);
|
||||
len > 0;
|
||||
len--, p1++, p2++)
|
||||
if (*p1 != *p2) return (intnat)*p1 - (intnat)*p2;
|
||||
res = memcmp(String_val(v1), String_val(v2), len1 <= len2 ? len1 : len2);
|
||||
if (res < 0) return LESS;
|
||||
if (res > 0) return GREATER;
|
||||
if (len1 != len2) return len1 - len2;
|
||||
break;
|
||||
}
|
||||
|
|
@ -198,12 +221,18 @@ static intnat compare_val(value v1, value v2, int total)
|
|||
case Custom_tag: {
|
||||
int res;
|
||||
int (*compare)(value v1, value v2) = Custom_ops_val(v1)->compare;
|
||||
/* Hardening against comparisons between different types */
|
||||
if (compare != Custom_ops_val(v2)->compare) {
|
||||
return strcmp(Custom_ops_val(v1)->identifier,
|
||||
Custom_ops_val(v2)->identifier) < 0
|
||||
? LESS : GREATER;
|
||||
}
|
||||
if (compare == NULL) {
|
||||
compare_free_stack();
|
||||
caml_invalid_argument("equal: abstract value");
|
||||
}
|
||||
caml_compare_unordered = 0;
|
||||
res = Custom_ops_val(v1)->compare(v1, v2);
|
||||
res = compare(v1, v2);
|
||||
if (caml_compare_unordered && !total) return UNORDERED;
|
||||
if (res != 0) return res;
|
||||
break;
|
||||
|
|
|
|||
|
|
@ -31,6 +31,7 @@ struct custom_operations {
|
|||
/*out*/ uintnat * wsize_32 /*size in bytes*/,
|
||||
/*out*/ uintnat * wsize_64 /*size in bytes*/);
|
||||
uintnat (*deserialize)(void * dst);
|
||||
int (*compare_ext)(value v1, value v2);
|
||||
};
|
||||
|
||||
#define custom_finalize_default NULL
|
||||
|
|
@ -38,6 +39,7 @@ struct custom_operations {
|
|||
#define custom_hash_default NULL
|
||||
#define custom_serialize_default NULL
|
||||
#define custom_deserialize_default NULL
|
||||
#define custom_compare_ext_default NULL
|
||||
|
||||
#define Custom_ops_val(v) (*((struct custom_operations **) (v)))
|
||||
|
||||
|
|
|
|||
|
|
@ -15,6 +15,8 @@
|
|||
|
||||
/* Raising exceptions from C. */
|
||||
|
||||
#include <stdio.h>
|
||||
#include <stdlib.h>
|
||||
#include "alloc.h"
|
||||
#include "fail.h"
|
||||
#include "io.h"
|
||||
|
|
@ -85,13 +87,24 @@ CAMLexport void caml_raise_with_string(value tag, char const *msg)
|
|||
CAMLnoreturn;
|
||||
}
|
||||
|
||||
/* PR#5115: Failure and Invalid_argument can be triggered by
|
||||
input_value while reading the initial value of [caml_global_data]. */
|
||||
|
||||
CAMLexport void caml_failwith (char const *msg)
|
||||
{
|
||||
if (caml_global_data == 0) {
|
||||
fprintf(stderr, "Fatal error: exception Failure(\"%s\")\n", msg);
|
||||
exit(2);
|
||||
}
|
||||
caml_raise_with_string(Field(caml_global_data, FAILURE_EXN), msg);
|
||||
}
|
||||
|
||||
CAMLexport void caml_invalid_argument (char const *msg)
|
||||
{
|
||||
if (caml_global_data == 0) {
|
||||
fprintf(stderr, "Fatal error: exception Invalid_argument(\"%s\")\n", msg);
|
||||
exit(2);
|
||||
}
|
||||
caml_raise_with_string(Field(caml_global_data, INVALID_EXN), msg);
|
||||
}
|
||||
|
||||
|
|
|
|||
|
|
@ -467,8 +467,11 @@ CAMLprim value caml_gc_major_slice (value v)
|
|||
|
||||
CAMLprim value caml_gc_compaction(value v)
|
||||
{ Assert (v == Val_unit);
|
||||
caml_gc_message (0x10, "Heap compaction requested\n", 0);
|
||||
caml_empty_minor_heap ();
|
||||
caml_finish_major_cycle ();
|
||||
caml_final_do_calls ();
|
||||
caml_empty_minor_heap ();
|
||||
caml_finish_major_cycle ();
|
||||
caml_compact_heap ();
|
||||
caml_final_do_calls ();
|
||||
|
|
@ -481,7 +484,9 @@ void caml_init_gc (uintnat minor_size, uintnat major_size,
|
|||
{
|
||||
uintnat major_heap_size = Bsize_wsize (norm_heapincr (major_size));
|
||||
|
||||
caml_page_table_initialize(Bsize_wsize(minor_size) + major_heap_size);
|
||||
if (caml_page_table_initialize(Bsize_wsize(minor_size) + major_heap_size)){
|
||||
caml_fatal_error ("OCaml runtime error: cannot initialize page table\n");
|
||||
}
|
||||
caml_set_minor_heap_size (Bsize_wsize (norm_minsize (minor_size)));
|
||||
caml_major_heap_increment = Bsize_wsize (norm_heapincr (major_incr));
|
||||
caml_percent_free = norm_pfree (percent_fr);
|
||||
|
|
|
|||
|
|
@ -625,7 +625,7 @@ static void nativeint_serialize(value v, uintnat * wsize_32,
|
|||
{
|
||||
intnat l = Nativeint_val(v);
|
||||
#ifdef ARCH_SIXTYFOUR
|
||||
if (l <= 0x7FFFFFFFL && l >= -0x80000000L) {
|
||||
if (l >= -((intnat)1 << 31) && l < ((intnat)1 << 31)) {
|
||||
caml_serialize_int_1(1);
|
||||
caml_serialize_int_4((int32) l);
|
||||
} else {
|
||||
|
|
|
|||
|
|
@ -54,7 +54,7 @@ extern char *caml_gc_sweep_hp;
|
|||
void caml_init_major_heap (asize_t); /* size in bytes */
|
||||
asize_t caml_round_heap_chunk_size (asize_t); /* size in bytes */
|
||||
void caml_darken (value, value *);
|
||||
intnat caml_major_collection_slice (long);
|
||||
intnat caml_major_collection_slice (intnat);
|
||||
void major_collection (void);
|
||||
void caml_finish_major_cycle (void);
|
||||
|
||||
|
|
|
|||
|
|
@ -28,7 +28,7 @@ CAMLexport value * caml_stack_threshold;
|
|||
CAMLexport value * caml_extern_sp;
|
||||
CAMLexport value * caml_trapsp;
|
||||
CAMLexport value * caml_trap_barrier;
|
||||
value caml_global_data;
|
||||
value caml_global_data = 0;
|
||||
|
||||
uintnat caml_max_stack_size; /* also used in gc_ctrl.c */
|
||||
|
||||
|
|
|
|||
|
|
@ -288,7 +288,7 @@ static int parse_command_line(char **argv)
|
|||
static void scanmult (char *opt, uintnat *var)
|
||||
{
|
||||
char mult = ' ';
|
||||
int val;
|
||||
unsigned int val;
|
||||
sscanf (opt, "=%u%c", &val, &mult);
|
||||
sscanf (opt, "=0x%x%c", &val, &mult);
|
||||
switch (mult) {
|
||||
|
|
|
|||
|
|
@ -138,12 +138,14 @@ CAMLprim value caml_sys_open(value path, value vflags, value vperm)
|
|||
/* open on a named FIFO can block (PR#1533) */
|
||||
caml_enter_blocking_section();
|
||||
fd = open(p, flags, perm);
|
||||
/* fcntl on a fd can block (PR#5069)*/
|
||||
#if defined(F_SETFD) && defined(FD_CLOEXEC)
|
||||
if (fd != -1)
|
||||
fcntl(fd, F_SETFD, FD_CLOEXEC);
|
||||
#endif
|
||||
caml_leave_blocking_section();
|
||||
caml_stat_free(p);
|
||||
if (fd == -1) caml_sys_error(path);
|
||||
#if defined(F_SETFD) && defined(FD_CLOEXEC)
|
||||
fcntl(fd, F_SETFD, FD_CLOEXEC);
|
||||
#endif
|
||||
CAMLreturn(Val_long(fd));
|
||||
}
|
||||
|
||||
|
|
|
|||
|
|
@ -198,6 +198,8 @@
|
|||
| MtSig of loc and sig_item
|
||||
(* mt with wc *)
|
||||
| MtWit of loc and module_type and with_constr
|
||||
(* module type of m *)
|
||||
| MtOf of loc and module_expr
|
||||
| MtAnt of loc and string (* $s$ *) ]
|
||||
and sig_item =
|
||||
[ SgNil of loc
|
||||
|
|
|
|||
|
|
@ -169,6 +169,7 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct
|
|||
method reset = {< pipe = False; semi = False >};
|
||||
|
||||
value semisep : sep = ";;";
|
||||
value no_semisep : sep = ""; (* used to mark where ";;" should not occur *)
|
||||
value mode = if comments then `comments else `no_comments;
|
||||
value curry_constr = init_curry_constr;
|
||||
value var_conversion = False;
|
||||
|
|
@ -878,6 +879,7 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct
|
|||
let () = o#node f mt Ast.loc_of_module_type in
|
||||
match mt with
|
||||
[ <:module_type<>> -> assert False
|
||||
| <:module_type< module type of $me$ >> -> pp f "@[<2>module type of@ %a@]" o#module_expr me
|
||||
| <:module_type< $id:i$ >> -> o#ident f i
|
||||
| <:module_type< $anti:s$ >> -> o#anti f s
|
||||
| <:module_type< functor ( $s$ : $mt1$ ) -> $mt2$ >> ->
|
||||
|
|
@ -1006,21 +1008,21 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct
|
|||
| <:class_sig_item< $csg1$; $csg2$ >> ->
|
||||
do { o#class_sig_item f csg1; cut f; o#class_sig_item f csg2 }
|
||||
| <:class_sig_item< constraint $t1$ = $t2$ >> ->
|
||||
pp f "@[<2>constraint@ %a =@ %a%(%)@]" o#ctyp t1 o#ctyp t2 semisep
|
||||
pp f "@[<2>constraint@ %a =@ %a%(%)@]" o#ctyp t1 o#ctyp t2 no_semisep
|
||||
| <:class_sig_item< inherit $ct$ >> ->
|
||||
pp f "@[<2>inherit@ %a%(%)@]" o#class_type ct semisep
|
||||
pp f "@[<2>inherit@ %a%(%)@]" o#class_type ct no_semisep
|
||||
| <:class_sig_item< method $private:pr$ $s$ : $t$ >> ->
|
||||
pp f "@[<2>method %a%a :@ %a%(%)@]" o#private_flag pr o#var s
|
||||
o#ctyp t semisep
|
||||
o#ctyp t no_semisep
|
||||
| <:class_sig_item< method virtual $private:pr$ $s$ : $t$ >> ->
|
||||
pp f "@[<2>method virtual %a%a :@ %a%(%)@]"
|
||||
o#private_flag pr o#var s o#ctyp t semisep
|
||||
o#private_flag pr o#var s o#ctyp t no_semisep
|
||||
| <:class_sig_item< value $mutable:mu$ $virtual:vi$ $s$ : $t$ >> ->
|
||||
pp f "@[<2>%s %a%a%a :@ %a%(%)@]"
|
||||
o#value_val o#mutable_flag mu o#virtual_flag vi o#var s o#ctyp t
|
||||
semisep
|
||||
no_semisep
|
||||
| <:class_sig_item< $anti:s$ >> ->
|
||||
pp f "%a%(%)" o#anti s semisep ];
|
||||
pp f "%a%(%)" o#anti s no_semisep ];
|
||||
|
||||
method class_str_item f cst =
|
||||
let () = o#node f cst Ast.loc_of_class_str_item in
|
||||
|
|
@ -1032,30 +1034,30 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct
|
|||
| <:class_str_item< $cst1$; $cst2$ >> ->
|
||||
do { o#class_str_item f cst1; cut f; o#class_str_item f cst2 }
|
||||
| <:class_str_item< constraint $t1$ = $t2$ >> ->
|
||||
pp f "@[<2>constraint %a =@ %a%(%)@]" o#ctyp t1 o#ctyp t2 semisep
|
||||
pp f "@[<2>constraint %a =@ %a%(%)@]" o#ctyp t1 o#ctyp t2 no_semisep
|
||||
| <:class_str_item< inherit $override:ov$ $ce$ >> ->
|
||||
pp f "@[<2>inherit%a@ %a%(%)@]" o#override_flag ov o#class_expr ce semisep
|
||||
pp f "@[<2>inherit%a@ %a%(%)@]" o#override_flag ov o#class_expr ce no_semisep
|
||||
| <:class_str_item< inherit $override:ov$ $ce$ as $lid:s$ >> ->
|
||||
pp f "@[<2>inherit%a@ %a as@ %a%(%)@]" o#override_flag ov o#class_expr ce o#var s semisep
|
||||
pp f "@[<2>inherit%a@ %a as@ %a%(%)@]" o#override_flag ov o#class_expr ce o#var s no_semisep
|
||||
| <:class_str_item< initializer $e$ >> ->
|
||||
pp f "@[<2>initializer@ %a%(%)@]" o#expr e semisep
|
||||
pp f "@[<2>initializer@ %a%(%)@]" o#expr e no_semisep
|
||||
| <:class_str_item< method $override:ov$ $private:pr$ $s$ = $e$ >> ->
|
||||
pp f "@[<2>method%a %a%a =@ %a%(%)@]"
|
||||
o#override_flag ov o#private_flag pr o#var s o#expr e semisep
|
||||
o#override_flag ov o#private_flag pr o#var s o#expr e no_semisep
|
||||
| <:class_str_item< method $override:ov$ $private:pr$ $s$ : $t$ = $e$ >> ->
|
||||
pp f "@[<2>method%a %a%a :@ %a =@ %a%(%)@]"
|
||||
o#override_flag ov o#private_flag pr o#var s o#ctyp t o#expr e semisep
|
||||
o#override_flag ov o#private_flag pr o#var s o#ctyp t o#expr e no_semisep
|
||||
| <:class_str_item< method virtual $private:pr$ $s$ : $t$ >> ->
|
||||
pp f "@[<2>method virtual@ %a%a :@ %a%(%)@]"
|
||||
o#private_flag pr o#var s o#ctyp t semisep
|
||||
o#private_flag pr o#var s o#ctyp t no_semisep
|
||||
| <:class_str_item< value virtual $mutable:mu$ $s$ : $t$ >> ->
|
||||
pp f "@[<2>%s virtual %a%a :@ %a%(%)@]"
|
||||
o#value_val o#mutable_flag mu o#var s o#ctyp t semisep
|
||||
o#value_val o#mutable_flag mu o#var s o#ctyp t no_semisep
|
||||
| <:class_str_item< value $override:ov$ $mutable:mu$ $s$ = $e$ >> ->
|
||||
pp f "@[<2>%s%a %a%a =@ %a%(%)@]"
|
||||
o#value_val o#override_flag ov o#mutable_flag mu o#var s o#expr e semisep
|
||||
o#value_val o#override_flag ov o#mutable_flag mu o#var s o#expr e no_semisep
|
||||
| <:class_str_item< $anti:s$ >> ->
|
||||
pp f "%a%(%)" o#anti s semisep ];
|
||||
pp f "%a%(%)" o#anti s no_semisep ];
|
||||
|
||||
method implem f st =
|
||||
match st with
|
||||
|
|
|
|||
|
|
@ -68,6 +68,7 @@ module Make (Syntax : Sig.Camlp4Syntax) : sig
|
|||
value pipe : bool;
|
||||
value semi : bool;
|
||||
value semisep : sep;
|
||||
value no_semisep : sep;
|
||||
method value_val : string;
|
||||
method value_let : string;
|
||||
method andsep : sep;
|
||||
|
|
|
|||
|
|
@ -44,6 +44,7 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct
|
|||
inherit PP_o.printer ~curry_constr:init_curry_constr ~comments () as super;
|
||||
|
||||
value! semisep : sep = ";";
|
||||
value! no_semisep : sep = ";";
|
||||
value mode = if comments then `comments else `no_comments;
|
||||
value curry_constr = init_curry_constr;
|
||||
value first_match_case = True;
|
||||
|
|
@ -267,7 +268,7 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct
|
|||
| <:class_expr< virtual $lid:i$ >> ->
|
||||
pp f "@[<2>virtual@ %a@]" o#var i
|
||||
| <:class_expr< virtual $lid:i$ [ $t$ ] >> ->
|
||||
pp f "@[<2>virtual@ %a@ @[<1>[%a]@]@]" o#var i o#ctyp t
|
||||
pp f "@[<2>virtual@ %a@ @[<1>[%a]@]@]" o#var i o#class_params t
|
||||
| ce -> super#class_expr f ce ];
|
||||
end;
|
||||
|
||||
|
|
|
|||
|
|
@ -51,11 +51,13 @@ value register_str_item_parser f = str_item_parser.val := f;
|
|||
value register_sig_item_parser f = sig_item_parser.val := f;
|
||||
value register_parser f g =
|
||||
do { str_item_parser.val := f; sig_item_parser.val := g };
|
||||
value current_parser () = (str_item_parser.val, sig_item_parser.val);
|
||||
|
||||
value register_str_item_printer f = str_item_printer.val := f;
|
||||
value register_sig_item_printer f = sig_item_printer.val := f;
|
||||
value register_printer f g =
|
||||
do { str_item_printer.val := f; sig_item_printer.val := g };
|
||||
value current_printer () = (str_item_printer.val, sig_item_printer.val);
|
||||
|
||||
module Plugin (Id : Sig.Id) (Maker : functor (Unit : sig end) -> sig end) = struct
|
||||
declare_dyn_module Id.name (fun _ -> let module M = Maker (struct end) in ());
|
||||
|
|
|
|||
|
|
@ -40,6 +40,7 @@ type parser_fun 'a =
|
|||
value register_str_item_parser : parser_fun PreCast.Ast.str_item -> unit;
|
||||
value register_sig_item_parser : parser_fun PreCast.Ast.sig_item -> unit;
|
||||
value register_parser : parser_fun PreCast.Ast.str_item -> parser_fun PreCast.Ast.sig_item -> unit;
|
||||
value current_parser : unit -> (parser_fun PreCast.Ast.str_item * parser_fun PreCast.Ast.sig_item);
|
||||
|
||||
module Parser
|
||||
(Id : Sig.Id) (Maker : functor (Ast : Sig.Ast) -> (Sig.Parser Ast).S) : sig end;
|
||||
|
|
@ -58,6 +59,7 @@ type printer_fun 'a =
|
|||
value register_str_item_printer : printer_fun PreCast.Ast.str_item -> unit;
|
||||
value register_sig_item_printer : printer_fun PreCast.Ast.sig_item -> unit;
|
||||
value register_printer : printer_fun PreCast.Ast.str_item -> printer_fun PreCast.Ast.sig_item -> unit;
|
||||
value current_printer : unit -> (printer_fun PreCast.Ast.str_item * printer_fun PreCast.Ast.sig_item);
|
||||
|
||||
module Printer
|
||||
(Id : Sig.Id)
|
||||
|
|
|
|||
|
|
@ -858,6 +858,8 @@ module Make (Ast : Sig.Camlp4Ast) = struct
|
|||
mkmty loc (Pmty_signature (sig_item sl []))
|
||||
| <:module_type@loc< $mt$ with $wc$ >> ->
|
||||
mkmty loc (Pmty_with (module_type mt) (mkwithc wc []))
|
||||
| <:module_type@loc< module type of $me$ >> ->
|
||||
mkmty loc (Pmty_typeof (module_expr me))
|
||||
| <:module_type< $anti:_$ >> -> assert False ]
|
||||
and sig_item s l =
|
||||
match s with
|
||||
|
|
|
|||
|
|
@ -36,6 +36,7 @@ module type S = sig
|
|||
|
||||
type token_info = { prev_loc : Loc.t
|
||||
; cur_loc : Loc.t
|
||||
; prev_loc_only : bool
|
||||
};
|
||||
|
||||
type token_stream = Stream.t (Token.t * token_info);
|
||||
|
|
@ -126,6 +127,7 @@ module Make (Lexer : Sig.Lexer) = struct
|
|||
|
||||
type token_info = { prev_loc : Loc.t
|
||||
; cur_loc : Loc.t
|
||||
; prev_loc_only : bool
|
||||
};
|
||||
|
||||
type token_stream = Stream.t (Token.t * token_info);
|
||||
|
|
|
|||
|
|
@ -17,16 +17,8 @@
|
|||
* - Nicolas Pouillard: refactoring
|
||||
*)
|
||||
|
||||
(* BEGIN ugly hack. See 15 lines down. FIXME *)
|
||||
|
||||
type prev_locs = {
|
||||
pl_strm : mutable Obj.t;
|
||||
pl_locs : mutable list (int * Obj.t)
|
||||
};
|
||||
|
||||
value prev_locs = ref ([] : list prev_locs);
|
||||
|
||||
(* END ugly hack FIXME *)
|
||||
(* PR#5090: don't do lookahead on get_prev_loc. *)
|
||||
value get_prev_loc_only = ref False;
|
||||
|
||||
module Make (Structure : Structure.S) = struct
|
||||
open Structure;
|
||||
|
|
@ -38,71 +30,20 @@ module Make (Structure : Structure.S) = struct
|
|||
[ [: ` x; strm :] -> [: ` (f x); stream_map f strm :]
|
||||
| [: :] -> [: :] ];
|
||||
|
||||
(* ******************************************************************* *)
|
||||
(* Ugly hack to prevent PR#5090. See how to do this properly after
|
||||
the 3.12.0 release. FIXME.
|
||||
*)
|
||||
|
||||
value keep_prev_loc strm =
|
||||
match Stream.peek strm with
|
||||
[ None -> [: :]
|
||||
| Some (_, init_loc) ->
|
||||
let myrecord = { pl_strm = Obj.repr [: :];
|
||||
pl_locs = [(0, Obj.repr init_loc)] }
|
||||
in
|
||||
let rec go prev_loc = parser
|
||||
[ [: `(tok, cur_loc); strm :] -> do {
|
||||
myrecord.pl_locs := myrecord.pl_locs
|
||||
@ [ (Stream.count strm, Obj.repr cur_loc) ];
|
||||
[: `(tok, {prev_loc; cur_loc}); go cur_loc strm :] }
|
||||
| [: :] -> do {
|
||||
prev_locs.val := List.filter ((!=) myrecord) prev_locs.val;
|
||||
[: :] } ]
|
||||
in
|
||||
let result = go init_loc strm in
|
||||
do {
|
||||
prev_locs.val := [myrecord :: prev_locs.val];
|
||||
myrecord.pl_strm := Obj.repr result;
|
||||
result } ];
|
||||
|
||||
value drop_prev_loc strm = stream_map (fun (tok,r) -> (tok,r)) strm;
|
||||
|
||||
value get_cur_loc strm =
|
||||
match Stream.peek strm with
|
||||
[ Some (_,r) -> r.cur_loc
|
||||
| None -> Loc.ghost ];
|
||||
|
||||
value get_prev_loc strm =
|
||||
let c = Stream.count strm in
|
||||
let rec drop l =
|
||||
match l with
|
||||
[ [] -> []
|
||||
| [(i, _) :: ll] -> if i < c then drop ll else l ]
|
||||
in
|
||||
let rec find l =
|
||||
match l with
|
||||
[ [] -> None
|
||||
| [h::t] -> if h.pl_strm == Obj.repr strm then Some h else find t ]
|
||||
in
|
||||
match find prev_locs.val with
|
||||
[ None -> Loc.ghost
|
||||
| Some r -> do {
|
||||
r.pl_locs := drop r.pl_locs;
|
||||
match r.pl_locs with
|
||||
[ [] -> Loc.ghost
|
||||
| [(i, loc) :: _] ->
|
||||
if i = c then (Obj.obj loc : Loc.t) else Loc.ghost ] } ];
|
||||
|
||||
(* ******************************************************************* *)
|
||||
(* END of ugly hack. This is the previous code.
|
||||
|
||||
value keep_prev_loc strm =
|
||||
match Stream.peek strm with
|
||||
[ None -> [: :]
|
||||
| Some (_,init_loc) ->
|
||||
let rec go prev_loc = parser
|
||||
[ [: `(tok,cur_loc); strm :] -> [: `(tok,{prev_loc;cur_loc}); go cur_loc strm :]
|
||||
| [: :] -> [: :] ]
|
||||
| Some (tok0,init_loc) ->
|
||||
let rec go prev_loc strm1 =
|
||||
if get_prev_loc_only.val then
|
||||
[: `(tok0, {prev_loc; cur_loc = prev_loc; prev_loc_only = True});
|
||||
go prev_loc strm1 :]
|
||||
else
|
||||
match strm1 with parser
|
||||
[ [: `(tok,cur_loc); strm :] ->
|
||||
[: `(tok, {prev_loc; cur_loc; prev_loc_only = False});
|
||||
go cur_loc strm :]
|
||||
| [: :] -> [: :] ]
|
||||
in go init_loc strm ];
|
||||
|
||||
value drop_prev_loc strm = stream_map (fun (tok,r) -> (tok,r.cur_loc)) strm;
|
||||
|
|
@ -113,11 +54,16 @@ value get_prev_loc strm =
|
|||
| None -> Loc.ghost ];
|
||||
|
||||
value get_prev_loc strm =
|
||||
match Stream.peek strm with
|
||||
[ Some (_,r) -> r.prev_loc
|
||||
| None -> Loc.ghost ];
|
||||
*)
|
||||
|
||||
begin
|
||||
get_prev_loc_only.val := True;
|
||||
let result = match Stream.peek strm with
|
||||
[ Some (_, {prev_loc; prev_loc_only = True}) ->
|
||||
begin Stream.junk strm; prev_loc end
|
||||
| Some (_, {prev_loc; prev_loc_only = False}) -> prev_loc
|
||||
| None -> Loc.ghost ];
|
||||
get_prev_loc_only.val := False;
|
||||
result
|
||||
end;
|
||||
|
||||
value is_level_labelled n lev =
|
||||
match lev.lname with
|
||||
|
|
|
|||
|
|
@ -180,6 +180,18 @@ module Make (Token : Sig.Camlp4Token)
|
|||
pos_lnum = if absolute then line else pos.pos_lnum + line;
|
||||
pos_bol = pos.pos_cnum - chars;
|
||||
}
|
||||
|
||||
(* To convert integer literals, copied from "../parsing/lexer.mll" *)
|
||||
|
||||
let cvt_int_literal s =
|
||||
- int_of_string ("-" ^ s)
|
||||
let cvt_int32_literal s =
|
||||
Int32.neg (Int32.of_string ("-" ^ s))
|
||||
let cvt_int64_literal s =
|
||||
Int64.neg (Int64.of_string ("-" ^ s))
|
||||
let cvt_nativeint_literal s =
|
||||
Nativeint.neg (Nativeint.of_string ("-" ^ s))
|
||||
|
||||
|
||||
let err error loc =
|
||||
raise(Loc.Exc_located(loc, Error.E error))
|
||||
|
|
@ -263,19 +275,19 @@ module Make (Token : Sig.Camlp4Token)
|
|||
| lowercase identchar * as x { LIDENT x }
|
||||
| uppercase identchar * as x { UIDENT x }
|
||||
| int_literal as i
|
||||
{ try INT(int_of_string i, i)
|
||||
{ try INT(cvt_int_literal i, i)
|
||||
with Failure _ -> err (Literal_overflow "int") (Loc.of_lexbuf lexbuf) }
|
||||
| float_literal as f
|
||||
{ try FLOAT(float_of_string f, f)
|
||||
with Failure _ -> err (Literal_overflow "float") (Loc.of_lexbuf lexbuf) }
|
||||
| (int_literal as i) "l"
|
||||
{ try INT32(Int32.of_string i, i)
|
||||
{ try INT32(cvt_int32_literal i, i)
|
||||
with Failure _ -> err (Literal_overflow "int32") (Loc.of_lexbuf lexbuf) }
|
||||
| (int_literal as i) "L"
|
||||
{ try INT64(Int64.of_string i, i)
|
||||
{ try INT64(cvt_int64_literal i, i)
|
||||
with Failure _ -> err (Literal_overflow "int64") (Loc.of_lexbuf lexbuf) }
|
||||
| (int_literal as i) "n"
|
||||
{ try NATIVEINT(Nativeint.of_string i, i)
|
||||
{ try NATIVEINT(cvt_nativeint_literal i, i)
|
||||
with Failure _ -> err (Literal_overflow "nativeint") (Loc.of_lexbuf lexbuf) }
|
||||
| '"'
|
||||
{ with_curr_loc string c;
|
||||
|
|
|
|||
|
|
@ -71,7 +71,7 @@ value rewrite_and_load n x =
|
|||
[ ("Parsers"|"", "pa_r.cmo" | "r" | "ocamlr" | "ocamlrevised" | "camlp4ocamlrevisedparser.cmo") -> load [pa_r]
|
||||
| ("Parsers"|"", "rr" | "reloaded" | "ocamlreloaded" | "camlp4ocamlreloadedparser.cmo") -> load [pa_rr]
|
||||
| ("Parsers"|"", "pa_o.cmo" | "o" | "ocaml" | "camlp4ocamlparser.cmo") -> load [pa_r; pa_o]
|
||||
| ("Parsers"|"", "pa_rp.cmo" | "rp" | "rparser" | "camlp4ocamlrevisedparserparser.cmo") -> load [pa_r; pa_o; pa_rp]
|
||||
| ("Parsers"|"", "pa_rp.cmo" | "rp" | "rparser" | "camlp4ocamlrevisedparserparser.cmo") -> load [pa_r; pa_rp]
|
||||
| ("Parsers"|"", "pa_op.cmo" | "op" | "parser" | "camlp4ocamlparserparser.cmo") -> load [pa_r; pa_o; pa_rp; pa_op]
|
||||
| ("Parsers"|"", "pa_extend.cmo" | "pa_extend_m.cmo" | "g" | "grammar" | "camlp4grammarparser.cmo") -> load [pa_g]
|
||||
| ("Parsers"|"", "pa_macro.cmo" | "m" | "macro" | "camlp4macroparser.cmo") -> load [pa_m]
|
||||
|
|
@ -79,7 +79,7 @@ value rewrite_and_load n x =
|
|||
| ("Parsers"|"", "q_mlast.cmo" | "rq" | "camlp4ocamlrevisedquotationexpander.cmo") -> load [pa_qb; pa_rq]
|
||||
| ("Parsers"|"", "oq" | "camlp4ocamloriginalquotationexpander.cmo") -> load [pa_r; pa_o; pa_qb; pa_oq]
|
||||
| ("Parsers"|"", "rf") -> load [pa_r; pa_rp; pa_qb; pa_q; pa_g; pa_l; pa_m]
|
||||
| ("Parsers"|"", "of") -> load [pa_r; pa_o; pa_rp; pa_op; pa_qb; pa_rq; pa_g; pa_l; pa_m]
|
||||
| ("Parsers"|"", "of") -> load [pa_r; pa_o; pa_rp; pa_op; pa_qb; pa_q; pa_g; pa_l; pa_m]
|
||||
| ("Parsers"|"", "comp" | "camlp4listcomprehension.cmo") -> load [pa_l]
|
||||
| ("Filters"|"", "lift" | "camlp4astlifter.cmo") -> load ["Camlp4AstLifter"]
|
||||
| ("Filters"|"", "exn" | "camlp4exceptiontracer.cmo") -> load ["Camlp4ExceptionTracer"]
|
||||
|
|
|
|||
|
|
@ -20,7 +20,7 @@ open Camlp4; (* -*- camlp4r -*- *)
|
|||
|
||||
|
||||
module Id = struct
|
||||
value name = "Camlp4ListComprenhsion";
|
||||
value name = "Camlp4ListComprehension";
|
||||
value version = Sys.ocaml_version;
|
||||
end;
|
||||
|
||||
|
|
|
|||
|
|
@ -405,6 +405,18 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct
|
|||
uident:
|
||||
[ [ i = UIDENT -> i ] ]
|
||||
;
|
||||
(* dirty hack to allow polymorphic variants using the introduced keywords. *)
|
||||
expr: BEFORE "simple"
|
||||
[ [ "`"; kwd = [ "IFDEF" | "IFNDEF" | "THEN" | "ELSE" | "END" | "ENDIF"
|
||||
| "DEFINE" | "IN" ] -> <:expr< `$uid:kwd$ >>
|
||||
| "`"; s = a_ident -> <:expr< ` $s$ >> ] ]
|
||||
;
|
||||
(* idem *)
|
||||
patt: BEFORE "simple"
|
||||
[ [ "`"; kwd = [ "IFDEF" | "IFNDEF" | "THEN" | "ELSE" | "END" | "ENDIF" ] ->
|
||||
<:patt< `$uid:kwd$ >>
|
||||
| "`"; s = a_ident -> <:patt< ` $s$ >> ] ]
|
||||
;
|
||||
END;
|
||||
|
||||
Options.add "-D" (Arg.String parse_def)
|
||||
|
|
|
|||
|
|
@ -73,6 +73,49 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct
|
|||
[ Some (KEYWORD ("."|"("),_) -> raise Stream.Failure
|
||||
| _ -> () ]);
|
||||
|
||||
(* horrible hacks to be able to parse class_types *)
|
||||
|
||||
value test_ctyp_minusgreater =
|
||||
Gram.Entry.of_parser "test_ctyp_minusgreater"
|
||||
(fun strm ->
|
||||
let rec skip_simple_ctyp n =
|
||||
match stream_peek_nth n strm with
|
||||
[ Some (KEYWORD "->") -> n
|
||||
| Some (KEYWORD ("[" | "[<")) ->
|
||||
skip_simple_ctyp (ignore_upto "]" (n + 1) + 1)
|
||||
| Some (KEYWORD "(") -> skip_simple_ctyp (ignore_upto ")" (n + 1) + 1)
|
||||
| Some
|
||||
(KEYWORD
|
||||
("as" | "'" | ":" | "*" | "." | "#" | "<" | ">" | ".." | ";" |
|
||||
"_" | "?")) ->
|
||||
skip_simple_ctyp (n + 1)
|
||||
| Some (LIDENT _ | UIDENT _) ->
|
||||
skip_simple_ctyp (n + 1)
|
||||
| Some _ | None -> raise Stream.Failure ]
|
||||
and ignore_upto end_kwd n =
|
||||
match stream_peek_nth n strm with
|
||||
[ Some (KEYWORD prm) when prm = end_kwd -> n
|
||||
| Some (KEYWORD ("[" | "[<")) ->
|
||||
ignore_upto end_kwd (ignore_upto "]" (n + 1) + 1)
|
||||
| Some (KEYWORD "(") -> ignore_upto end_kwd (ignore_upto ")" (n + 1) + 1)
|
||||
| Some _ -> ignore_upto end_kwd (n + 1)
|
||||
| None -> raise Stream.Failure ]
|
||||
in
|
||||
match Stream.peek strm with
|
||||
[ Some ((KEYWORD "[" | LIDENT _ | UIDENT _), _) -> skip_simple_ctyp 1
|
||||
| Some (KEYWORD "object", _) -> raise Stream.Failure
|
||||
| _ -> 1 ])
|
||||
;
|
||||
|
||||
value lident_colon =
|
||||
Gram.Entry.of_parser "lident_colon"
|
||||
(fun strm ->
|
||||
match Stream.npeek 2 strm with
|
||||
[ [(LIDENT i, _); (KEYWORD ":", _)] ->
|
||||
do { Stream.junk strm; Stream.junk strm; i }
|
||||
| _ -> raise Stream.Failure ])
|
||||
;
|
||||
|
||||
value rec is_ident_constr_call =
|
||||
fun
|
||||
[ <:ident< $uid:_$ >> -> True
|
||||
|
|
@ -402,15 +445,15 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct
|
|||
| t = ctyp -> t ] ]
|
||||
;
|
||||
class_type_plus:
|
||||
[ [ i = TRY [i = a_LIDENT; ":" -> i]; t = ctyp LEVEL "star"; "->"; ct = SELF ->
|
||||
[ [ i = lident_colon; t = ctyp LEVEL "star"; "->"; ct = SELF ->
|
||||
<:class_type< [ ~ $i$ : $t$ ] -> $ct$ >>
|
||||
| "?"; i = a_LIDENT; ":"; t = ctyp LEVEL "star"; "->"; ct = SELF ->
|
||||
<:class_type< [ ? $i$ : $t$ ] -> $ct$ >>
|
||||
| i = OPTLABEL (* FIXME inline a_OPTLABEL *); t = ctyp LEVEL "star"; "->"; ct = SELF ->
|
||||
<:class_type< [ ? $i$ : $t$ ] -> $ct$ >>
|
||||
| t = TRY [t = ctyp LEVEL "star"; "->" -> t]; ct = SELF ->
|
||||
| test_ctyp_minusgreater; t = ctyp LEVEL "star"; "->"; ct = SELF ->
|
||||
<:class_type< [ $t$ ] -> $ct$ >>
|
||||
| ct = TRY class_type -> ct ] ]
|
||||
| ct = class_type -> ct ] ]
|
||||
;
|
||||
class_type_longident_and_param:
|
||||
[ [ "["; t = comma_ctyp; "]"; i = class_type_longident ->
|
||||
|
|
@ -540,6 +583,13 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct
|
|||
| "{"; t = label_declaration_list; "}" ->
|
||||
<:ctyp< { $t$ } >> ] ]
|
||||
;
|
||||
ctyp_quot:
|
||||
[ [ "private"; t = ctyp_quot -> <:ctyp< private $t$ >>
|
||||
| "|"; t = constructor_declarations -> <:ctyp< [ $t$ ] >>
|
||||
| x = more_ctyp; "="; y = ctyp_quot -> <:ctyp< $x$ == $y$ >>
|
||||
| "{"; t = label_declaration_list; "}" -> <:ctyp< { $t$ } >>
|
||||
] ]
|
||||
;
|
||||
module_expr: LEVEL "apply"
|
||||
[ [ i = SELF; "("; j = SELF; ")" -> <:module_expr< $i$ $j$ >> ] ]
|
||||
;
|
||||
|
|
@ -587,6 +637,8 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct
|
|||
<:patt< ~ $i$ : ($lid:i$ : $t$) >>
|
||||
| i = a_OPTLABEL; j = a_LIDENT -> (* ?a:b <> ?a : b *)
|
||||
<:patt< ? $i$ : ($lid:j$) >>
|
||||
| i = a_OPTLABEL; "_" ->
|
||||
<:patt< ? $i$ : (_) >>
|
||||
| i = a_OPTLABEL; "("; p = patt; ")" ->
|
||||
<:patt< ? $i$ : ($p$) >>
|
||||
| i = a_OPTLABEL; "("; p = patt; "="; e = expr; ")" ->
|
||||
|
|
|
|||
|
|
@ -33,19 +33,19 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct
|
|||
value help_sequences () =
|
||||
do {
|
||||
Printf.eprintf "\
|
||||
New syntax:\n\
|
||||
(e1; e2; ... ; en) OR begin e1; e2; ... ; en end\n\
|
||||
while e do e1; e2; ... ; en done\n\
|
||||
for v = v1 to/downto v2 do e1; e2; ... ; en done\n\
|
||||
Old syntax (still supported):\n\
|
||||
do {e1; e2; ... ; en}\n\
|
||||
while e do {e1; e2; ... ; en}\n\
|
||||
for v = v1 to/downto v2 do {e1; e2; ... ; en}\n\
|
||||
Very old (no more supported) syntax:\n\
|
||||
do e1; e2; ... ; en-1; return en\n\
|
||||
while e do e1; e2; ... ; en; done\n\
|
||||
for v = v1 to/downto v2 do e1; e2; ... ; en; done\n\
|
||||
";
|
||||
New syntax:\
|
||||
\n (e1; e2; ... ; en) OR begin e1; e2; ... ; en end\
|
||||
\n while e do e1; e2; ... ; en done\
|
||||
\n for v = v1 to/downto v2 do e1; e2; ... ; en done\
|
||||
\nOld syntax (still supported):\
|
||||
\n do {e1; e2; ... ; en}\
|
||||
\n while e do {e1; e2; ... ; en}\
|
||||
\n for v = v1 to/downto v2 do {e1; e2; ... ; en}\
|
||||
\nVery old (no more supported) syntax:\
|
||||
\n do e1; e2; ... ; en-1; return en\
|
||||
\n while e do e1; e2; ... ; en; done\
|
||||
\n for v = v1 to/downto v2 do e1; e2; ... ; en; done\
|
||||
\n";
|
||||
flush stderr;
|
||||
exit 1
|
||||
}
|
||||
|
|
@ -462,7 +462,7 @@ Very old (no more supported) syntax:\n\
|
|||
<:str_item< module $i$ = $mb$ >>
|
||||
| "module"; "rec"; mb = module_binding ->
|
||||
<:str_item< module rec $mb$ >>
|
||||
| "module"; "type"; i = a_UIDENT; "="; mt = module_type ->
|
||||
| "module"; "type"; i = a_ident; "="; mt = module_type ->
|
||||
<:str_item< module type $i$ = $mt$ >>
|
||||
| "open"; i = module_longident -> <:str_item< open $i$ >>
|
||||
| "type"; td = type_declaration ->
|
||||
|
|
@ -520,7 +520,8 @@ Very old (no more supported) syntax:\n\
|
|||
| `QUOTATION x -> Quotation.expand _loc x Quotation.DynAst.module_type_tag
|
||||
| i = module_longident_with_app -> <:module_type< $id:i$ >>
|
||||
| "'"; i = a_ident -> <:module_type< ' $i$ >>
|
||||
| "("; mt = SELF; ")" -> <:module_type< $mt$ >> ] ]
|
||||
| "("; mt = SELF; ")" -> <:module_type< $mt$ >>
|
||||
| "module"; "type"; "of"; me = module_expr -> <:module_type< module type of $me$ >> ] ]
|
||||
;
|
||||
sig_item:
|
||||
[ "top"
|
||||
|
|
@ -536,9 +537,9 @@ Very old (no more supported) syntax:\n\
|
|||
<:sig_item< module $i$ : $mt$ >>
|
||||
| "module"; "rec"; mb = module_rec_declaration ->
|
||||
<:sig_item< module rec $mb$ >>
|
||||
| "module"; "type"; i = a_UIDENT; "="; mt = module_type ->
|
||||
| "module"; "type"; i = a_ident; "="; mt = module_type ->
|
||||
<:sig_item< module type $i$ = $mt$ >>
|
||||
| "module"; "type"; i = a_UIDENT ->
|
||||
| "module"; "type"; i = a_ident ->
|
||||
<:sig_item< module type $i$ >>
|
||||
| "open"; i = module_longident -> <:sig_item< open $i$ >>
|
||||
| "type"; t = type_declaration ->
|
||||
|
|
@ -1455,7 +1456,7 @@ Very old (no more supported) syntax:\n\
|
|||
<:rec_binding< $anti:mk_anti ~c:"rec_binding" n s$ >>
|
||||
| `ANTIQUOT ("list" as n) s ->
|
||||
<:rec_binding< $anti:mk_anti ~c:"rec_binding" n s$ >>
|
||||
| l = label; "="; e = expr -> <:rec_binding< $lid:l$ = $e$ >> ] ]
|
||||
| l = label; "="; e = expr LEVEL "top" -> <:rec_binding< $lid:l$ = $e$ >> ] ]
|
||||
;
|
||||
meth_list:
|
||||
[ [ m = meth_decl; ";"; (ml, v) = SELF -> (<:ctyp< $m$; $ml$ >>, v)
|
||||
|
|
@ -1740,7 +1741,7 @@ Very old (no more supported) syntax:\n\
|
|||
more_ctyp:
|
||||
[ [ "mutable"; x = SELF -> <:ctyp< mutable $x$ >>
|
||||
| "`"; x = a_ident -> <:ctyp< `$x$ >>
|
||||
| x = type_kind -> x
|
||||
| x = ctyp -> x
|
||||
| x = type_parameter -> x
|
||||
] ]
|
||||
;
|
||||
|
|
|
|||
|
|
@ -90,7 +90,7 @@ module Make (Syntax : Sig.Camlp4Syntax)
|
|||
| "`int32" -> <:expr< Int32.to_string $e$ >>
|
||||
| "`int64" -> <:expr< Int64.to_string $e$ >>
|
||||
| "`nativeint" -> <:expr< Nativeint.to_string $e$ >>
|
||||
| "`flo" -> <:expr< string_of_float $e$ >>
|
||||
| "`flo" -> <:expr< Camlp4_import.Oprint.float_repres $e$ >>
|
||||
| "`str" -> <:expr< Ast.safe_string_escaped $e$ >>
|
||||
| "`chr" -> <:expr< Char.escaped $e$ >>
|
||||
| "`bool" -> <:expr< Ast.IdUid $mloc _loc$ (if $e$ then "True" else "False") >>
|
||||
|
|
|
|||
|
|
@ -229,8 +229,20 @@ and print_simple_out_type ppf =
|
|||
fprintf ppf "@[<hv 2>{ %a }@]"
|
||||
(print_list print_out_label (fun ppf -> fprintf ppf ";@ ")) lbls
|
||||
| Otyp_abstract -> fprintf ppf "<abstract>"
|
||||
| Otyp_module (p, n, tyl) ->
|
||||
do {
|
||||
fprintf ppf "@[<1>(module %s" p;
|
||||
let first = ref True in
|
||||
List.iter2
|
||||
(fun s t ->
|
||||
let sep = if first.val then do { first.val := False; "with" } else "and" in
|
||||
fprintf ppf " %s type %s = %a" sep s print_out_type t
|
||||
)
|
||||
n tyl;
|
||||
fprintf ppf ")@]"
|
||||
}
|
||||
| Otyp_alias _ _ | Otyp_poly _ _
|
||||
| Otyp_arrow _ _ _ | Otyp_constr _ [_ :: _] | Otyp_module _ as ty ->
|
||||
| Otyp_arrow _ _ _ | Otyp_constr _ [_ :: _] as ty ->
|
||||
fprintf ppf "@[<1>(%a)@]" print_out_type ty ]
|
||||
in
|
||||
print_tkind ppf
|
||||
|
|
@ -281,7 +293,7 @@ and print_typargs ppf =
|
|||
| tyl ->
|
||||
fprintf ppf "@[<1>(%a)@]@ " (print_typlist print_out_type ",") tyl ]
|
||||
and print_ty_label ppf lab =
|
||||
if lab <> "" then fprintf ppf "~%s:" lab else ()
|
||||
if lab <> "" then fprintf ppf "%s%s:" (if lab.[0] = '?' then "" else "~") lab else ()
|
||||
;
|
||||
|
||||
value type_parameter ppf (ty, (co, cn)) =
|
||||
|
|
@ -348,12 +360,24 @@ value rec print_out_module_type ppf =
|
|||
fprintf ppf "@[<2>functor@ (%s : %a) ->@ %a@]" name
|
||||
print_out_module_type mty_arg print_out_module_type mty_res
|
||||
| Omty_abstract -> () ]
|
||||
and needs_semi =
|
||||
fun
|
||||
[ Osig_class _ _ _ _ rs
|
||||
| Osig_class_type _ _ _ _ rs
|
||||
| Osig_module _ _ rs
|
||||
| Osig_type _ rs -> rs <> Orec_next
|
||||
| Osig_exception _ _
|
||||
| Osig_modtype _ _
|
||||
| Osig_value _ _ _ -> True ]
|
||||
and print_out_signature ppf =
|
||||
fun
|
||||
[ [] -> ()
|
||||
| [item] -> fprintf ppf "%a;" Toploop.print_out_sig_item.val item
|
||||
| [item :: items] ->
|
||||
fprintf ppf "%a;@ %a" Toploop.print_out_sig_item.val item
|
||||
let sep = match items with
|
||||
[ [hd :: _] -> if needs_semi hd then ";" else ""
|
||||
| [] -> ";" ] in
|
||||
fprintf ppf "%a%s@ %a" Toploop.print_out_sig_item.val item sep
|
||||
print_out_signature items ]
|
||||
and print_out_sig_item ppf =
|
||||
fun
|
||||
|
|
|
|||
File diff suppressed because it is too large
Load Diff
|
|
@ -1826,6 +1826,14 @@ module Make (Loc : Sig.Loc) : Sig.Camlp4Ast with module Loc = Loc =
|
|||
and meta_module_type _loc =
|
||||
fun
|
||||
[ Ast.MtAnt x0 x1 -> Ast.ExAnt x0 x1
|
||||
| Ast.MtOf x0 x1 ->
|
||||
Ast.ExApp _loc
|
||||
(Ast.ExApp _loc
|
||||
(Ast.ExId _loc
|
||||
(Ast.IdAcc _loc (Ast.IdUid _loc "Ast")
|
||||
(Ast.IdUid _loc "MtOf")))
|
||||
(meta_loc _loc x0))
|
||||
(meta_module_expr _loc x1)
|
||||
| Ast.MtWit x0 x1 x2 ->
|
||||
Ast.ExApp _loc
|
||||
(Ast.ExApp _loc
|
||||
|
|
@ -3902,6 +3910,14 @@ module Make (Loc : Sig.Loc) : Sig.Camlp4Ast with module Loc = Loc =
|
|||
and meta_module_type _loc =
|
||||
fun
|
||||
[ Ast.MtAnt x0 x1 -> Ast.PaAnt x0 x1
|
||||
| Ast.MtOf x0 x1 ->
|
||||
Ast.PaApp _loc
|
||||
(Ast.PaApp _loc
|
||||
(Ast.PaId _loc
|
||||
(Ast.IdAcc _loc (Ast.IdUid _loc "Ast")
|
||||
(Ast.IdUid _loc "MtOf")))
|
||||
(meta_loc _loc x0))
|
||||
(meta_module_expr _loc x1)
|
||||
| Ast.MtWit x0 x1 x2 ->
|
||||
Ast.PaApp _loc
|
||||
(Ast.PaApp _loc
|
||||
|
|
@ -4922,6 +4938,9 @@ module Make (Loc : Sig.Loc) : Sig.Camlp4Ast with module Loc = Loc =
|
|||
let _x = o#loc _x in
|
||||
let _x_i1 = o#module_type _x_i1 in
|
||||
let _x_i2 = o#with_constr _x_i2 in MtWit _x _x_i1 _x_i2
|
||||
| MtOf _x _x_i1 ->
|
||||
let _x = o#loc _x in
|
||||
let _x_i1 = o#module_expr _x_i1 in MtOf _x _x_i1
|
||||
| MtAnt _x _x_i1 ->
|
||||
let _x = o#loc _x in
|
||||
let _x_i1 = o#string _x_i1 in MtAnt _x _x_i1 ];
|
||||
|
|
@ -5698,6 +5717,8 @@ module Make (Loc : Sig.Loc) : Sig.Camlp4Ast with module Loc = Loc =
|
|||
| MtWit _x _x_i1 _x_i2 ->
|
||||
let o = o#loc _x in
|
||||
let o = o#module_type _x_i1 in let o = o#with_constr _x_i2 in o
|
||||
| MtOf _x _x_i1 ->
|
||||
let o = o#loc _x in let o = o#module_expr _x_i1 in o
|
||||
| MtAnt _x _x_i1 -> let o = o#loc _x in let o = o#string _x_i1 in o ];
|
||||
method module_expr : module_expr -> 'self_type =
|
||||
fun
|
||||
|
|
|
|||
|
|
@ -40,19 +40,19 @@ module R =
|
|||
let help_sequences () =
|
||||
(Printf.eprintf
|
||||
"\
|
||||
New syntax:\n\
|
||||
(e1; e2; ... ; en) OR begin e1; e2; ... ; en end\n\
|
||||
while e do e1; e2; ... ; en done\n\
|
||||
for v = v1 to/downto v2 do e1; e2; ... ; en done\n\
|
||||
Old syntax (still supported):\n\
|
||||
do {e1; e2; ... ; en}\n\
|
||||
while e do {e1; e2; ... ; en}\n\
|
||||
for v = v1 to/downto v2 do {e1; e2; ... ; en}\n\
|
||||
Very old (no more supported) syntax:\n\
|
||||
do e1; e2; ... ; en-1; return en\n\
|
||||
while e do e1; e2; ... ; en; done\n\
|
||||
for v = v1 to/downto v2 do e1; e2; ... ; en; done\n\
|
||||
";
|
||||
New syntax:\
|
||||
\n (e1; e2; ... ; en) OR begin e1; e2; ... ; en end\
|
||||
\n while e do e1; e2; ... ; en done\
|
||||
\n for v = v1 to/downto v2 do e1; e2; ... ; en done\
|
||||
\nOld syntax (still supported):\
|
||||
\n do {e1; e2; ... ; en}\
|
||||
\n while e do {e1; e2; ... ; en}\
|
||||
\n for v = v1 to/downto v2 do {e1; e2; ... ; en}\
|
||||
\nVery old (no more supported) syntax:\
|
||||
\n do e1; e2; ... ; en-1; return en\
|
||||
\n while e do e1; e2; ... ; en; done\
|
||||
\n for v = v1 to/downto v2 do e1; e2; ... ; en; done\
|
||||
\n";
|
||||
flush stderr;
|
||||
exit 1)
|
||||
|
||||
|
|
@ -1148,13 +1148,13 @@ Very old (no more supported) syntax:\n\
|
|||
([ Gram.Skeyword "module"; Gram.Skeyword "type";
|
||||
Gram.Snterm
|
||||
(Gram.Entry.obj
|
||||
(a_UIDENT : 'a_UIDENT Gram.Entry.t));
|
||||
(a_ident : 'a_ident Gram.Entry.t));
|
||||
Gram.Skeyword "=";
|
||||
Gram.Snterm
|
||||
(Gram.Entry.obj
|
||||
(module_type : 'module_type Gram.Entry.t)) ],
|
||||
(Gram.Action.mk
|
||||
(fun (mt : 'module_type) _ (i : 'a_UIDENT) _ _
|
||||
(fun (mt : 'module_type) _ (i : 'a_ident) _ _
|
||||
(_loc : Gram.Loc.t) ->
|
||||
(Ast.StMty (_loc, i, mt) : 'str_item))));
|
||||
([ Gram.Skeyword "module"; Gram.Skeyword "rec";
|
||||
|
|
@ -1406,7 +1406,16 @@ Very old (no more supported) syntax:\n\
|
|||
(fun _ (sg : 'sig_items) _ (_loc : Gram.Loc.t)
|
||||
-> (Ast.MtSig (_loc, sg) : 'module_type)))) ]);
|
||||
((Some "simple"), None,
|
||||
[ ([ Gram.Skeyword "("; Gram.Sself; Gram.Skeyword ")" ],
|
||||
[ ([ Gram.Skeyword "module"; Gram.Skeyword "type";
|
||||
Gram.Skeyword "of";
|
||||
Gram.Snterm
|
||||
(Gram.Entry.obj
|
||||
(module_expr : 'module_expr Gram.Entry.t)) ],
|
||||
(Gram.Action.mk
|
||||
(fun (me : 'module_expr) _ _ _
|
||||
(_loc : Gram.Loc.t) ->
|
||||
(Ast.MtOf (_loc, me) : 'module_type))));
|
||||
([ Gram.Skeyword "("; Gram.Sself; Gram.Skeyword ")" ],
|
||||
(Gram.Action.mk
|
||||
(fun _ (mt : 'module_type) _ (_loc : Gram.Loc.t)
|
||||
-> (mt : 'module_type))));
|
||||
|
|
@ -1511,21 +1520,21 @@ Very old (no more supported) syntax:\n\
|
|||
([ Gram.Skeyword "module"; Gram.Skeyword "type";
|
||||
Gram.Snterm
|
||||
(Gram.Entry.obj
|
||||
(a_UIDENT : 'a_UIDENT Gram.Entry.t)) ],
|
||||
(a_ident : 'a_ident Gram.Entry.t)) ],
|
||||
(Gram.Action.mk
|
||||
(fun (i : 'a_UIDENT) _ _ (_loc : Gram.Loc.t) ->
|
||||
(fun (i : 'a_ident) _ _ (_loc : Gram.Loc.t) ->
|
||||
(Ast.SgMty (_loc, i, (Ast.MtNil _loc)) :
|
||||
'sig_item))));
|
||||
([ Gram.Skeyword "module"; Gram.Skeyword "type";
|
||||
Gram.Snterm
|
||||
(Gram.Entry.obj
|
||||
(a_UIDENT : 'a_UIDENT Gram.Entry.t));
|
||||
(a_ident : 'a_ident Gram.Entry.t));
|
||||
Gram.Skeyword "=";
|
||||
Gram.Snterm
|
||||
(Gram.Entry.obj
|
||||
(module_type : 'module_type Gram.Entry.t)) ],
|
||||
(Gram.Action.mk
|
||||
(fun (mt : 'module_type) _ (i : 'a_UIDENT) _ _
|
||||
(fun (mt : 'module_type) _ (i : 'a_ident) _ _
|
||||
(_loc : Gram.Loc.t) ->
|
||||
(Ast.SgMty (_loc, i, mt) : 'sig_item))));
|
||||
([ Gram.Skeyword "module"; Gram.Skeyword "rec";
|
||||
|
|
@ -6873,8 +6882,9 @@ Very old (no more supported) syntax:\n\
|
|||
[ ([ Gram.Snterm
|
||||
(Gram.Entry.obj (label : 'label Gram.Entry.t));
|
||||
Gram.Skeyword "=";
|
||||
Gram.Snterm
|
||||
(Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ],
|
||||
Gram.Snterml
|
||||
((Gram.Entry.obj (expr : 'expr Gram.Entry.t)),
|
||||
"top") ],
|
||||
(Gram.Action.mk
|
||||
(fun (e : 'expr) _ (l : 'label)
|
||||
(_loc : Gram.Loc.t) ->
|
||||
|
|
@ -8529,10 +8539,9 @@ Very old (no more supported) syntax:\n\
|
|||
(fun (x : 'type_parameter) (_loc : Gram.Loc.t)
|
||||
-> (x : 'more_ctyp))));
|
||||
([ Gram.Snterm
|
||||
(Gram.Entry.obj
|
||||
(type_kind : 'type_kind Gram.Entry.t)) ],
|
||||
(Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ],
|
||||
(Gram.Action.mk
|
||||
(fun (x : 'type_kind) (_loc : Gram.Loc.t) ->
|
||||
(fun (x : 'ctyp) (_loc : Gram.Loc.t) ->
|
||||
(x : 'more_ctyp))));
|
||||
([ Gram.Skeyword "`";
|
||||
Gram.Snterm
|
||||
|
|
@ -9292,7 +9301,6 @@ module Camlp4QuotationCommon =
|
|||
let antiquot_expander =
|
||||
object
|
||||
inherit Ast.map as super
|
||||
|
||||
method patt =
|
||||
function
|
||||
| (Ast.PaAnt (_loc, s) | Ast.PaStr (_loc, s) as p) ->
|
||||
|
|
@ -9457,7 +9465,6 @@ module Camlp4QuotationCommon =
|
|||
p)
|
||||
| _ -> p)
|
||||
| p -> super#patt p
|
||||
|
||||
method expr =
|
||||
function
|
||||
| (Ast.ExAnt (_loc, s) | Ast.ExStr (_loc, s) as e) ->
|
||||
|
|
@ -9496,7 +9503,11 @@ module Camlp4QuotationCommon =
|
|||
| "`flo" ->
|
||||
Ast.ExApp (_loc,
|
||||
(Ast.ExId (_loc,
|
||||
(Ast.IdLid (_loc, "string_of_float")))),
|
||||
(Ast.IdAcc (_loc,
|
||||
(Ast.IdUid (_loc, "Camlp4_import")),
|
||||
(Ast.IdAcc (_loc,
|
||||
(Ast.IdUid (_loc, "Oprint")),
|
||||
(Ast.IdLid (_loc, "float_repres")))))))),
|
||||
e)
|
||||
| "`str" ->
|
||||
Ast.ExApp (_loc,
|
||||
|
|
@ -9853,7 +9864,6 @@ module Camlp4QuotationCommon =
|
|||
e)
|
||||
| _ -> e)
|
||||
| e -> super#expr e
|
||||
|
||||
end
|
||||
|
||||
let add_quotation name entry mexpr mpatt =
|
||||
|
|
@ -11846,12 +11856,10 @@ module G =
|
|||
|
||||
class subst gmod =
|
||||
object inherit Ast.map as super
|
||||
|
||||
method ident =
|
||||
function
|
||||
| Ast.IdUid (_, x) when x = gm -> gmod
|
||||
| x -> super#ident x
|
||||
|
||||
end
|
||||
|
||||
let subst_gmod ast gmod = (new subst gmod)#expr ast
|
||||
|
|
@ -11905,13 +11913,11 @@ module G =
|
|||
let wildcarder =
|
||||
object (self)
|
||||
inherit Ast.map as super
|
||||
|
||||
method patt =
|
||||
function
|
||||
| Ast.PaId (_loc, (Ast.IdLid (_, _))) -> Ast.PaAny _loc
|
||||
| Ast.PaAli (_, p, _) -> self#patt p
|
||||
| p -> super#patt p
|
||||
|
||||
end
|
||||
|
||||
let mk_tok _loc p t =
|
||||
|
|
@ -13599,14 +13605,11 @@ Added statements:
|
|||
in loop
|
||||
|
||||
class reloc _loc =
|
||||
object inherit Ast.map as super
|
||||
method loc = fun _ -> _loc
|
||||
end
|
||||
object inherit Ast.map as super method loc = fun _ -> _loc end
|
||||
|
||||
(* method _Loc_t _ = _loc; *)
|
||||
class subst _loc env =
|
||||
object inherit reloc _loc as super
|
||||
|
||||
method expr =
|
||||
function
|
||||
| (Ast.ExId (_, (Ast.IdLid (_, x))) |
|
||||
|
|
@ -13614,7 +13617,6 @@ Added statements:
|
|||
as e) ->
|
||||
(try List.assoc x env with | Not_found -> super#expr e)
|
||||
| e -> super#expr e
|
||||
|
||||
method patt =
|
||||
function
|
||||
| (Ast.PaId (_, (Ast.IdLid (_, x))) |
|
||||
|
|
@ -13623,7 +13625,6 @@ Added statements:
|
|||
(try substp _loc [] (List.assoc x env)
|
||||
with | Not_found -> super#patt p)
|
||||
| p -> super#patt p
|
||||
|
||||
end
|
||||
|
||||
let incorrect_number loc l1 l2 =
|
||||
|
|
@ -14481,6 +14482,112 @@ Added statements:
|
|||
(fun (i : Gram.Token.t) (_loc : Gram.Loc.t) ->
|
||||
(let i = Gram.Token.extract_string i in i :
|
||||
'uident)))) ]) ]))
|
||||
());
|
||||
Gram.extend
|
||||
(* dirty hack to allow polymorphic variants using the introduced keywords. *)
|
||||
(expr : 'expr Gram.Entry.t)
|
||||
((fun () ->
|
||||
((Some (Camlp4.Sig.Grammar.Before "simple")),
|
||||
[ (None, None,
|
||||
[ ([ Gram.Skeyword "`";
|
||||
Gram.Snterm
|
||||
(Gram.Entry.obj
|
||||
(a_ident : 'a_ident Gram.Entry.t)) ],
|
||||
(Gram.Action.mk
|
||||
(fun (s : 'a_ident) _ (_loc : Gram.Loc.t) ->
|
||||
(Ast.ExVrn (_loc, s) : 'expr))));
|
||||
([ Gram.Skeyword "`";
|
||||
Gram.srules expr
|
||||
[ ([ Gram.Skeyword "IN" ],
|
||||
(Gram.Action.mk
|
||||
(fun (x : Gram.Token.t)
|
||||
(_loc : Gram.Loc.t) ->
|
||||
(Gram.Token.extract_string x : 'e__30))));
|
||||
([ Gram.Skeyword "DEFINE" ],
|
||||
(Gram.Action.mk
|
||||
(fun (x : Gram.Token.t)
|
||||
(_loc : Gram.Loc.t) ->
|
||||
(Gram.Token.extract_string x : 'e__30))));
|
||||
([ Gram.Skeyword "ENDIF" ],
|
||||
(Gram.Action.mk
|
||||
(fun (x : Gram.Token.t)
|
||||
(_loc : Gram.Loc.t) ->
|
||||
(Gram.Token.extract_string x : 'e__30))));
|
||||
([ Gram.Skeyword "END" ],
|
||||
(Gram.Action.mk
|
||||
(fun (x : Gram.Token.t)
|
||||
(_loc : Gram.Loc.t) ->
|
||||
(Gram.Token.extract_string x : 'e__30))));
|
||||
([ Gram.Skeyword "ELSE" ],
|
||||
(Gram.Action.mk
|
||||
(fun (x : Gram.Token.t)
|
||||
(_loc : Gram.Loc.t) ->
|
||||
(Gram.Token.extract_string x : 'e__30))));
|
||||
([ Gram.Skeyword "THEN" ],
|
||||
(Gram.Action.mk
|
||||
(fun (x : Gram.Token.t)
|
||||
(_loc : Gram.Loc.t) ->
|
||||
(Gram.Token.extract_string x : 'e__30))));
|
||||
([ Gram.Skeyword "IFNDEF" ],
|
||||
(Gram.Action.mk
|
||||
(fun (x : Gram.Token.t)
|
||||
(_loc : Gram.Loc.t) ->
|
||||
(Gram.Token.extract_string x : 'e__30))));
|
||||
([ Gram.Skeyword "IFDEF" ],
|
||||
(Gram.Action.mk
|
||||
(fun (x : Gram.Token.t)
|
||||
(_loc : Gram.Loc.t) ->
|
||||
(Gram.Token.extract_string x : 'e__30)))) ] ],
|
||||
(Gram.Action.mk
|
||||
(fun (kwd : 'e__30) _ (_loc : Gram.Loc.t) ->
|
||||
(Ast.ExVrn (_loc, kwd) : 'expr)))) ]) ]))
|
||||
());
|
||||
Gram.extend (* idem *) (patt : 'patt Gram.Entry.t)
|
||||
((fun () ->
|
||||
((Some (Camlp4.Sig.Grammar.Before "simple")),
|
||||
[ (None, None,
|
||||
[ ([ Gram.Skeyword "`";
|
||||
Gram.Snterm
|
||||
(Gram.Entry.obj
|
||||
(a_ident : 'a_ident Gram.Entry.t)) ],
|
||||
(Gram.Action.mk
|
||||
(fun (s : 'a_ident) _ (_loc : Gram.Loc.t) ->
|
||||
(Ast.PaVrn (_loc, s) : 'patt))));
|
||||
([ Gram.Skeyword "`";
|
||||
Gram.srules patt
|
||||
[ ([ Gram.Skeyword "ENDIF" ],
|
||||
(Gram.Action.mk
|
||||
(fun (x : Gram.Token.t)
|
||||
(_loc : Gram.Loc.t) ->
|
||||
(Gram.Token.extract_string x : 'e__31))));
|
||||
([ Gram.Skeyword "END" ],
|
||||
(Gram.Action.mk
|
||||
(fun (x : Gram.Token.t)
|
||||
(_loc : Gram.Loc.t) ->
|
||||
(Gram.Token.extract_string x : 'e__31))));
|
||||
([ Gram.Skeyword "ELSE" ],
|
||||
(Gram.Action.mk
|
||||
(fun (x : Gram.Token.t)
|
||||
(_loc : Gram.Loc.t) ->
|
||||
(Gram.Token.extract_string x : 'e__31))));
|
||||
([ Gram.Skeyword "THEN" ],
|
||||
(Gram.Action.mk
|
||||
(fun (x : Gram.Token.t)
|
||||
(_loc : Gram.Loc.t) ->
|
||||
(Gram.Token.extract_string x : 'e__31))));
|
||||
([ Gram.Skeyword "IFNDEF" ],
|
||||
(Gram.Action.mk
|
||||
(fun (x : Gram.Token.t)
|
||||
(_loc : Gram.Loc.t) ->
|
||||
(Gram.Token.extract_string x : 'e__31))));
|
||||
([ Gram.Skeyword "IFDEF" ],
|
||||
(Gram.Action.mk
|
||||
(fun (x : Gram.Token.t)
|
||||
(_loc : Gram.Loc.t) ->
|
||||
(Gram.Token.extract_string x : 'e__31)))) ] ],
|
||||
(Gram.Action.mk
|
||||
(fun (kwd : 'e__31) _ (_loc : Gram.Loc.t) ->
|
||||
(Ast.PaVrn (_loc, kwd) : 'patt)))) ]) ]))
|
||||
()))
|
||||
|
||||
let _ =
|
||||
|
|
@ -14740,7 +14847,7 @@ module L =
|
|||
*)
|
||||
module Id =
|
||||
struct
|
||||
let name = "Camlp4ListComprenhsion"
|
||||
let name = "Camlp4ListComprehension"
|
||||
|
||||
let version = Sys.ocaml_version
|
||||
|
||||
|
|
@ -15022,12 +15129,12 @@ module L =
|
|||
Gram.Skeyword "<-" ],
|
||||
(Gram.Action.mk
|
||||
(fun _ (p : 'patt) (_loc : Gram.Loc.t)
|
||||
-> (p : 'e__30)))) ]);
|
||||
-> (p : 'e__32)))) ]);
|
||||
Gram.Snterml
|
||||
((Gram.Entry.obj (expr : 'expr Gram.Entry.t)),
|
||||
"top") ],
|
||||
(Gram.Action.mk
|
||||
(fun (e : 'expr) (p : 'e__30)
|
||||
(fun (e : 'expr) (p : 'e__32)
|
||||
(_loc : Gram.Loc.t) ->
|
||||
(`gen ((p, e)) : 'item)))) ]) ]))
|
||||
()))
|
||||
|
|
@ -15217,7 +15324,7 @@ module B =
|
|||
| (("Parsers" | ""),
|
||||
("pa_rp.cmo" | "rp" | "rparser" |
|
||||
"camlp4ocamlrevisedparserparser.cmo"))
|
||||
-> load [ pa_r; pa_o; pa_rp ]
|
||||
-> load [ pa_r; pa_rp ]
|
||||
| (("Parsers" | ""),
|
||||
("pa_op.cmo" | "op" | "parser" | "camlp4ocamlparserparser.cmo"))
|
||||
-> load [ pa_r; pa_o; pa_rp; pa_op ]
|
||||
|
|
@ -15241,7 +15348,7 @@ module B =
|
|||
load [ pa_r; pa_rp; pa_qb; pa_q; pa_g; pa_l; pa_m ]
|
||||
| (("Parsers" | ""), "of") ->
|
||||
load
|
||||
[ pa_r; pa_o; pa_rp; pa_op; pa_qb; pa_rq; pa_g; pa_l; pa_m ]
|
||||
[ pa_r; pa_o; pa_rp; pa_op; pa_qb; pa_q; pa_g; pa_l; pa_m ]
|
||||
| (("Parsers" | ""), ("comp" | "camlp4listcomprehension.cmo")) ->
|
||||
load [ pa_l ]
|
||||
| (("Filters" | ""), ("lift" | "camlp4astlifter.cmo")) ->
|
||||
|
|
@ -15250,7 +15357,8 @@ module B =
|
|||
load [ "Camlp4ExceptionTracer" ]
|
||||
| (("Filters" | ""), ("prof" | "camlp4profiler.cmo")) ->
|
||||
load [ "Camlp4Profiler" ]
|
||||
| (("Filters" | ""), ("map" | "camlp4mapgenerator.cmo")) ->
|
||||
| (* map is now an alias of fold since fold handles map too *)
|
||||
(("Filters" | ""), ("map" | "camlp4mapgenerator.cmo")) ->
|
||||
load [ "Camlp4FoldGenerator" ]
|
||||
| (("Filters" | ""), ("fold" | "camlp4foldgenerator.cmo")) ->
|
||||
load [ "Camlp4FoldGenerator" ]
|
||||
|
|
@ -15278,7 +15386,6 @@ module B =
|
|||
in real_load (try find_in_path y with | Not_found -> x));
|
||||
!rcall_callback ())
|
||||
|
||||
(* map is now an alias of fold since fold handles map too *)
|
||||
let print_warning = eprintf "%a:\n%s@." Loc.print
|
||||
|
||||
let rec parse_file dyn_loader name pa getdir =
|
||||
|
|
@ -15354,17 +15461,17 @@ Options:\n\
|
|||
<file>.%s Load this module inside the Camlp4 core@."
|
||||
(if DynLoader.is_native then "cmxs " else "(cmo|cma)");
|
||||
Options.print_usage_list ini_sl;
|
||||
(* loop (ini_sl @ ext_sl) where rec loop =
|
||||
fun
|
||||
[ [(y, _, _) :: _] when y = "-help" -> ()
|
||||
| [_ :: sl] -> loop sl
|
||||
| [] -> eprintf " -help Display this list of options.@." ]; *)
|
||||
if ext_sl <> []
|
||||
then
|
||||
(eprintf "Options added by loaded object files:@.";
|
||||
Options.print_usage_list ext_sl)
|
||||
else ())
|
||||
|
||||
(* loop (ini_sl @ ext_sl) where rec loop =
|
||||
fun
|
||||
[ [(y, _, _) :: _] when y = "-help" -> ()
|
||||
| [_ :: sl] -> loop sl
|
||||
| [] -> eprintf " -help Display this list of options.@." ]; *)
|
||||
let warn_noassert () =
|
||||
eprintf
|
||||
"\
|
||||
|
|
|
|||
|
|
@ -63,7 +63,7 @@ try do {
|
|||
close_out cout
|
||||
};
|
||||
|
||||
run (["ocamlc"; "-I"; camlp4_standard_library; "camlp4lib.cma"; crc_ml]
|
||||
run (["ocamlc"; "-I"; camlp4_standard_library; "dynlink.cma"; "camlp4lib.cma"; crc_ml]
|
||||
@ includes @ options @ ["Camlp4Bin.cmo"; "-linkall"]);
|
||||
clean();
|
||||
}
|
||||
|
|
|
|||
|
|
@ -0,0 +1,26 @@
|
|||
/***********************************************************************/
|
||||
/* */
|
||||
/* Objective Caml */
|
||||
/* */
|
||||
/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
|
||||
/* */
|
||||
/* Copyright 2011 Institut National de Recherche en Informatique et */
|
||||
/* en Automatique. All rights reserved. This file is distributed */
|
||||
/* under the terms of the GNU Library General Public License, with */
|
||||
/* the special exception on linking described in file ../../LICENSE. */
|
||||
/* */
|
||||
/***********************************************************************/
|
||||
|
||||
/* $Id: longlong.c 4833 2002-05-25 08:33:26Z xleroy $ */
|
||||
|
||||
#include <math.h>
|
||||
|
||||
volatile double x;
|
||||
|
||||
int main(int argc, char **argv)
|
||||
{
|
||||
x = 3.1415;
|
||||
x = expm1(x);
|
||||
x = log1p(x);
|
||||
return 0;
|
||||
}
|
||||
|
|
@ -436,11 +436,12 @@ esac
|
|||
# Determine alignment constraints
|
||||
|
||||
case "$host" in
|
||||
sparc*-*-*|hppa*-*-*|arm*-*-*)
|
||||
sparc*-*-*|hppa*-*-*|arm*-*-*|mips*-*-*)
|
||||
# On Sparc V9 with certain versions of gcc, determination of double
|
||||
# alignment is not reliable (PR#1521), hence force it.
|
||||
# Same goes for hppa.
|
||||
# PR#5088 suggests same problem on ARM.
|
||||
# PR#5280 reports same problem on MIPS.
|
||||
# But there's a knack (PR#2572):
|
||||
# if we're in 64-bit mode (sizeof(long) == 8),
|
||||
# we must not doubleword-align floats...
|
||||
|
|
@ -468,8 +469,8 @@ esac
|
|||
|
||||
if $int64_native; then
|
||||
case "$host" in
|
||||
# PR#5088: autodetection is unreliable on ARM
|
||||
sparc*-*-*|hppa*-*-*|arm*-*-*)
|
||||
# PR#5088: autodetection is unreliable on ARM. PR#5280: also on MIPS.
|
||||
sparc*-*-*|hppa*-*-*|arm*-*-*|mips*-*-*)
|
||||
if test $2 = 8; then
|
||||
echo "64-bit integers can be word-aligned."
|
||||
echo "#undef ARCH_ALIGN_INT64" >> m.h
|
||||
|
|
@ -1539,6 +1540,10 @@ if test $has_tk = true; then
|
|||
fi
|
||||
fi
|
||||
|
||||
case "$host" in
|
||||
*-*-cygwin*) tk_libs="$tk_libs -lws2_32";;
|
||||
esac
|
||||
|
||||
if test $has_tk = true; then
|
||||
if sh ./hasgot $tk_libs $tk_x11_libs $tkauxlibs Tk_SetGrid; then
|
||||
echo "Tcl/Tk libraries found."
|
||||
|
|
|
|||
|
|
@ -1008,10 +1008,10 @@ Argument N means do this N times (or till program stops for another reason)." };
|
|||
(* Breakpoints *)
|
||||
{ instr_name = "break"; instr_prio = false;
|
||||
instr_action = instr_break; instr_repeat = false; instr_help =
|
||||
"Set breakpoint at specified line or function.\n\
|
||||
Syntax: break function-name\n\
|
||||
break @ [module] linenum\n\
|
||||
break @ [module] # characternum" };
|
||||
"Set breakpoint at specified line or function.\
|
||||
\nSyntax: break function-name\
|
||||
\n break @ [module] linenum\
|
||||
\n break @ [module] # characternum" };
|
||||
{ instr_name = "delete"; instr_prio = false;
|
||||
instr_action = instr_delete; instr_repeat = false; instr_help =
|
||||
"delete some breakpoints.\n\
|
||||
|
|
|
|||
|
|
@ -72,5 +72,9 @@ ocamltags: ocamltags.in
|
|||
install-ocamltags: ocamltags
|
||||
cp ocamltags $(SCRIPTDIR)/ocamltags
|
||||
|
||||
# This is for testing purposes
|
||||
compile-only:
|
||||
$(EMACS) --batch --eval '$(COMPILECMD)'
|
||||
|
||||
clean:
|
||||
rm -f ocamltags *~ #*#
|
||||
rm -f ocamltags *~ #*# *.elc
|
||||
|
|
|
|||
|
|
@ -39,5 +39,8 @@
|
|||
(or (member 'drag modifiers)
|
||||
(member 'click modifiers)))))
|
||||
|
||||
(if (fboundp 'string-to-number)
|
||||
(defalias 'caml-string-to-int 'string-to-number)
|
||||
(defalias 'caml-string-to-int 'string-to-int))
|
||||
|
||||
(provide 'caml-emacs)
|
||||
|
|
|
|||
|
|
@ -59,7 +59,7 @@
|
|||
. font-lock-builtin-face)
|
||||
;control
|
||||
(,(concat "[|#&]\\|->\\|"
|
||||
(regexp-opt '("do" "done" "dowto" "else" "for" "if" "ignore"
|
||||
(regexp-opt '("do" "done" "downto" "else" "for" "if" "ignore"
|
||||
"lazy" "match" "new" "or" "then" "to" "try"
|
||||
"when" "while" "with")
|
||||
'words))
|
||||
|
|
|
|||
|
|
@ -264,13 +264,13 @@ See `caml-types-location-re' for annotation file format.
|
|||
((string-match def-re kind)
|
||||
(let ((var-name (match-string 1 kind))
|
||||
(l-file (file-name-nondirectory (match-string 2 kind)))
|
||||
(l-line (string-to-int (match-string 4 kind)))
|
||||
(l-bol (string-to-int (match-string 5 kind)))
|
||||
(l-cnum (string-to-int (match-string 6 kind)))
|
||||
(l-line (caml-string-to-int (match-string 4 kind)))
|
||||
(l-bol (caml-string-to-int (match-string 5 kind)))
|
||||
(l-cnum (caml-string-to-int (match-string 6 kind)))
|
||||
(r-file (file-name-nondirectory (match-string 7 kind)))
|
||||
(r-line (string-to-int (match-string 9 kind)))
|
||||
(r-bol (string-to-int (match-string 10 kind)))
|
||||
(r-cnum (string-to-int (match-string 11 kind))))
|
||||
(r-line (caml-string-to-int (match-string 9 kind)))
|
||||
(r-bol (caml-string-to-int (match-string 10 kind)))
|
||||
(r-cnum (caml-string-to-int (match-string 11 kind))))
|
||||
(let* ((lpos (vector l-file l-line l-bol l-cnum))
|
||||
(rpos (vector r-file r-line r-bol r-cnum))
|
||||
(left (caml-types-get-pos target-buf lpos))
|
||||
|
|
@ -280,9 +280,9 @@ See `caml-types-location-re' for annotation file format.
|
|||
((string-match def-end-re kind)
|
||||
(let ((var-name (match-string 1 kind))
|
||||
(l-file (file-name-nondirectory (match-string 2 kind)))
|
||||
(l-line (string-to-int (match-string 4 kind)))
|
||||
(l-bol (string-to-int (match-string 5 kind)))
|
||||
(l-cnum (string-to-int (match-string 6 kind))))
|
||||
(l-line (caml-string-to-int (match-string 4 kind)))
|
||||
(l-bol (caml-string-to-int (match-string 5 kind)))
|
||||
(l-cnum (caml-string-to-int (match-string 6 kind))))
|
||||
(let* ((lpos (vector l-file l-line l-bol l-cnum))
|
||||
(left (caml-types-get-pos target-buf lpos))
|
||||
(right (buffer-size target-buf)))
|
||||
|
|
@ -291,13 +291,13 @@ See `caml-types-location-re' for annotation file format.
|
|||
((string-match internal-re kind)
|
||||
(let ((var-name (match-string 1 kind))
|
||||
(l-file (file-name-nondirectory (match-string 2 kind)))
|
||||
(l-line (string-to-int (match-string 4 kind)))
|
||||
(l-bol (string-to-int (match-string 5 kind)))
|
||||
(l-cnum (string-to-int (match-string 6 kind)))
|
||||
(l-line (caml-string-to-int (match-string 4 kind)))
|
||||
(l-bol (caml-string-to-int (match-string 5 kind)))
|
||||
(l-cnum (caml-string-to-int (match-string 6 kind)))
|
||||
(r-file (file-name-nondirectory (match-string 7 kind)))
|
||||
(r-line (string-to-int (match-string 9 kind)))
|
||||
(r-bol (string-to-int (match-string 10 kind)))
|
||||
(r-cnum (string-to-int (match-string 11 kind))))
|
||||
(r-line (caml-string-to-int (match-string 9 kind)))
|
||||
(r-bol (caml-string-to-int (match-string 10 kind)))
|
||||
(r-cnum (caml-string-to-int (match-string 11 kind))))
|
||||
(let* ((lpos (vector l-file l-line l-bol l-cnum))
|
||||
(rpos (vector r-file r-line r-bol r-cnum))
|
||||
(left (caml-types-get-pos target-buf lpos))
|
||||
|
|
@ -345,11 +345,12 @@ See `caml-types-location-re' for annotation file format.
|
|||
(message "done"))
|
||||
)))
|
||||
|
||||
(defun caml-types-parent-dir (d) (file-name-directory (directory-file-name d)))
|
||||
|
||||
(defun caml-types-locate-type-file (target-path)
|
||||
(let ((sibling (concat (file-name-sans-extension target-path) ".annot")))
|
||||
(if (file-exists-p sibling)
|
||||
sibling
|
||||
(defun parent-dir (d) (file-name-directory (directory-file-name d)))
|
||||
(let ((project-dir (file-name-directory sibling))
|
||||
type-path)
|
||||
(while (not (file-exists-p
|
||||
|
|
@ -357,10 +358,10 @@ See `caml-types-location-re' for annotation file format.
|
|||
(expand-file-name
|
||||
(file-relative-name sibling project-dir)
|
||||
(expand-file-name "_build" project-dir)))))
|
||||
(if (equal project-dir (parent-dir project-dir))
|
||||
(if (equal project-dir (caml-types-parent-dir project-dir))
|
||||
(error (concat "No annotation file. "
|
||||
"You should compile with option \"-annot\".")))
|
||||
(setq project-dir (parent-dir project-dir)))
|
||||
(setq project-dir (caml-types-parent-dir project-dir)))
|
||||
type-path))))
|
||||
|
||||
(defun caml-types-date< (date1 date2)
|
||||
|
|
@ -400,13 +401,13 @@ See `caml-types-location-re' for annotation file format.
|
|||
(annotation ()))
|
||||
(while (re-search-forward caml-types-location-re () t)
|
||||
(let ((l-file (file-name-nondirectory (match-string 1)))
|
||||
(l-line (string-to-int (match-string 3)))
|
||||
(l-bol (string-to-int (match-string 4)))
|
||||
(l-cnum (string-to-int (match-string 5)))
|
||||
(l-line (caml-string-to-int (match-string 3)))
|
||||
(l-bol (caml-string-to-int (match-string 4)))
|
||||
(l-cnum (caml-string-to-int (match-string 5)))
|
||||
(r-file (file-name-nondirectory (match-string 6)))
|
||||
(r-line (string-to-int (match-string 8)))
|
||||
(r-bol (string-to-int (match-string 9)))
|
||||
(r-cnum (string-to-int (match-string 10))))
|
||||
(r-line (caml-string-to-int (match-string 8)))
|
||||
(r-bol (caml-string-to-int (match-string 9)))
|
||||
(r-cnum (caml-string-to-int (match-string 10))))
|
||||
(unless (caml-types-not-in-file l-file r-file target-file)
|
||||
(setq annotation ())
|
||||
(while (next-annotation)
|
||||
|
|
|
|||
|
|
@ -50,4 +50,8 @@
|
|||
(and (button-release-event-p event)
|
||||
(equal (event-button original) (event-button event))))
|
||||
|
||||
(if (fboundp 'string-to-number)
|
||||
(defalias 'caml-string-to-int 'string-to-number)
|
||||
(defalias 'caml-string-to-int 'string-to-int))
|
||||
|
||||
(provide 'caml-xemacs)
|
||||
|
|
|
|||
|
|
@ -813,8 +813,9 @@ from an error message produced by camlc.")
|
|||
(defvar caml-error-overlay nil)
|
||||
(defvar caml-next-error-skip-warnings-flag nil)
|
||||
|
||||
(defun caml-string-to-int (x)
|
||||
(if (fboundp 'string-to-number) (string-to-number x) (string-to-int x)))
|
||||
(if (fboundp 'string-to-number)
|
||||
(defalias 'caml-string-to-int 'string-to-number)
|
||||
(defalias 'caml-string-to-int 'string-to-int))
|
||||
|
||||
;;itz 04-21-96 somebody didn't get the documentation for next-error
|
||||
;;right. When the optional argument is a number n, it should move
|
||||
|
|
@ -1160,7 +1161,7 @@ Used to distinguish it from toplevel let construct.")
|
|||
|
||||
(defconst caml-matching-kw-regexp
|
||||
(concat
|
||||
"\\<\\(and\\|do\\(ne\\)?\\|e\\(lse\\|nd\\)\\|in\\|t\\(hen\\|o\\)"
|
||||
"\\<\\(and\\|do\\(ne\\|wnto\\)?\\|e\\(lse\\|nd\\)\\|in\\|t\\(hen\\|o\\)"
|
||||
"\\|with\\)\\>\\|[^[|]|")
|
||||
"Regexp used in caml mode for skipping back over nested blocks.")
|
||||
|
||||
|
|
@ -1175,6 +1176,7 @@ Used to distinguish it from toplevel let construct.")
|
|||
("else" . caml-find-else-match)
|
||||
("then" . caml-find-then-match)
|
||||
("to" . caml-find-done-match)
|
||||
("downto" . caml-find-done-match)
|
||||
("do" . caml-find-done-match)
|
||||
("and" . caml-find-and-match))
|
||||
|
||||
|
|
@ -1581,7 +1583,7 @@ Does not preserve point."
|
|||
|
||||
(defconst caml-leading-kwops-regexp
|
||||
(concat
|
||||
"\\<\\(and\\|do\\(ne\\)?\\|e\\(lse\\|nd\\)\\|in"
|
||||
"\\<\\(and\\|do\\(ne\\|wnto\\)?\\|e\\(lse\\|nd\\)\\|in"
|
||||
"\\|t\\(hen\\|o\\)\\|with\\)\\>\\|[]|})]")
|
||||
|
||||
"Regexp matching caml keywords which need special indentation.")
|
||||
|
|
@ -1595,6 +1597,7 @@ Does not preserve point."
|
|||
("in" caml-in-extra-indent 2)
|
||||
("then" caml-then-extra-indent 3)
|
||||
("to" caml-to-extra-indent 0)
|
||||
("downto" caml-to-extra-indent 0)
|
||||
("with" caml-with-extra-indent 2)
|
||||
("|" caml-|-extra-indent 2)
|
||||
("]" caml-rb-extra-indent 0)
|
||||
|
|
|
|||
|
|
@ -302,8 +302,8 @@ buffer, then try to obtain the time from context around point."
|
|||
((save-excursion
|
||||
(beginning-of-line 1)
|
||||
(looking-at "^Time : \\([0-9]+\\) - pc : [0-9]+ "))
|
||||
(string-to-int (match-string 1)))
|
||||
((string-to-int (camldebug-format-command "%e"))))))
|
||||
(caml-string-to-int (match-string 1)))
|
||||
((caml-string-to-int (camldebug-format-command "%e"))))))
|
||||
(camldebug-call "goto" nil time)))
|
||||
(t
|
||||
(let ((module (camldebug-module-name (buffer-file-name)))
|
||||
|
|
@ -325,7 +325,7 @@ buffer, then try to obtain the time from context around point."
|
|||
" - module "
|
||||
module "$") nil t)
|
||||
(match-string 1)))))
|
||||
(if address (camldebug-call "goto" nil (string-to-int address))
|
||||
(if address (camldebug-call "goto" nil (caml-string-to-int address))
|
||||
(error "No time at %s at %s" module camldebug-goto-position))))))
|
||||
|
||||
|
||||
|
|
@ -383,12 +383,12 @@ around point."
|
|||
(arg (cond
|
||||
((eobp)
|
||||
(save-excursion (re-search-backward bpline nil t))
|
||||
(string-to-int (match-string 1)))
|
||||
(caml-string-to-int (match-string 1)))
|
||||
((save-excursion
|
||||
(beginning-of-line 1)
|
||||
(looking-at bpline))
|
||||
(string-to-int (match-string 1)))
|
||||
((string-to-int (camldebug-format-command "%e"))))))
|
||||
(caml-string-to-int (match-string 1)))
|
||||
((caml-string-to-int (camldebug-format-command "%e"))))))
|
||||
(camldebug-call "delete" nil arg)))
|
||||
(t
|
||||
(let ((camldebug-delete-file
|
||||
|
|
@ -409,7 +409,7 @@ around point."
|
|||
camldebug-delete-file
|
||||
camldebug-delete-position)
|
||||
(camldebug-call "delete" nil
|
||||
(string-to-int camldebug-delete-output)))))))))
|
||||
(caml-string-to-int camldebug-delete-output)))))))))
|
||||
|
||||
(defun camldebug-complete-filter (string)
|
||||
(setq camldebug-filter-accumulator
|
||||
|
|
@ -529,9 +529,9 @@ the camldebug commands `cd DIR' and `directory'."
|
|||
(let ((isbefore
|
||||
(string= "before"
|
||||
(match-string 5 camldebug-filter-accumulator)))
|
||||
(startpos (string-to-int
|
||||
(startpos (caml-string-to-int
|
||||
(match-string 3 camldebug-filter-accumulator)))
|
||||
(endpos (string-to-int
|
||||
(endpos (caml-string-to-int
|
||||
(match-string 4 camldebug-filter-accumulator))))
|
||||
(list (match-string 2 camldebug-filter-accumulator)
|
||||
(if isbefore startpos endpos)
|
||||
|
|
@ -704,7 +704,7 @@ Obeying it means displaying in another window the specified file and line."
|
|||
(move-overlay camldebug-overlay-under spos (- epos 1) buffer))
|
||||
(save-excursion
|
||||
(set-buffer buffer)
|
||||
(goto-char pos)
|
||||
(goto-char spos)
|
||||
(beginning-of-line)
|
||||
(move-marker camldebug-event-marker (point))
|
||||
(setq overlay-arrow-position camldebug-event-marker))))
|
||||
|
|
|
|||
|
|
@ -163,7 +163,7 @@ Input and output via buffer `*inferior-caml*'."
|
|||
(setq count (+ count 1)))
|
||||
(if (equal (buffer-name (current-buffer))
|
||||
inferior-caml-buffer-name)
|
||||
(end-of-buffer))
|
||||
(goto-char (point-max)))
|
||||
(while
|
||||
(> count 0)
|
||||
(previous-multiframe-window)
|
||||
|
|
@ -201,7 +201,7 @@ Input and output via buffer `*inferior-caml*'."
|
|||
(re-search-backward
|
||||
(concat comint-prompt-regexp
|
||||
"[ \t]*Characters[ \t]+\\([0-9]+\\)-[0-9]+:$"))
|
||||
(string-to-int (match-string 1))))))
|
||||
(caml-string-to-int (match-string 1))))))
|
||||
(goto-char loc)))
|
||||
|
||||
|
||||
|
|
@ -265,8 +265,8 @@ should lies."
|
|||
(cond ((re-search-forward
|
||||
" *Characters \\([01-9][01-9]*\\)-\\([1-9][01-9]*\\):\n[^W]"
|
||||
(point-max) t)
|
||||
(setq beg (string-to-int (caml-match-string 1)))
|
||||
(setq end (string-to-int (caml-match-string 2)))
|
||||
(setq beg (caml-string-to-int (caml-match-string 1)))
|
||||
(setq end (caml-string-to-int (caml-match-string 2)))
|
||||
(switch-to-buffer buf)
|
||||
(goto-char orig)
|
||||
(forward-byte end)
|
||||
|
|
@ -330,7 +330,7 @@ should lies."
|
|||
(beep) (if wait (read-event) (caml-sit-for 60)))
|
||||
(delete-overlay caml-error-overlay)))))
|
||||
|
||||
;; wait some amount for ouput, that is, until inferior-caml-output is set
|
||||
;; wait some amount for output, that is, until inferior-caml-output is set
|
||||
;; to true. Hence, interleaves sitting for shorts delays and checking the
|
||||
;; flag. Give up after some time. Typing into the source buffer will cancel
|
||||
;; waiting, i.e. may report 'No result yet'
|
||||
|
|
|
|||
|
|
@ -74,8 +74,8 @@ let output_tables oc tbl =
|
|||
|
||||
let output_entry sourcefile ic oc oci e =
|
||||
let init_num, init_moves = e.auto_initial_state in
|
||||
fprintf oc "%s %alexbuf =\n\
|
||||
%a%a __ocaml_lex_%s_rec %alexbuf %d\n"
|
||||
fprintf oc "%s %alexbuf =\
|
||||
\n %a%a __ocaml_lex_%s_rec %alexbuf %d\n"
|
||||
e.auto_name
|
||||
output_args e.auto_args
|
||||
(fun oc x ->
|
||||
|
|
|
|||
|
|
@ -20,31 +20,31 @@ open Lexgen
|
|||
open Common
|
||||
|
||||
let output_auto_defs oc =
|
||||
fprintf oc "let __ocaml_lex_init_lexbuf lexbuf mem_size =\n\
|
||||
let pos = lexbuf.Lexing.lex_curr_pos in\n\
|
||||
lexbuf.Lexing.lex_mem <- Array.create mem_size (-1) ;\n\
|
||||
lexbuf.Lexing.lex_start_pos <- pos ;\n\
|
||||
lexbuf.Lexing.lex_last_pos <- pos ;\n\
|
||||
lexbuf.Lexing.lex_last_action <- -1\n\
|
||||
\n\
|
||||
fprintf oc "let __ocaml_lex_init_lexbuf lexbuf mem_size =\
|
||||
\n let pos = lexbuf.Lexing.lex_curr_pos in\
|
||||
\n lexbuf.Lexing.lex_mem <- Array.create mem_size (-1) ;\
|
||||
\n lexbuf.Lexing.lex_start_pos <- pos ;\
|
||||
\n lexbuf.Lexing.lex_last_pos <- pos ;\
|
||||
\n lexbuf.Lexing.lex_last_action <- -1\
|
||||
\n\n\
|
||||
" ;
|
||||
|
||||
output_string oc
|
||||
"let rec __ocaml_lex_next_char lexbuf =\n\
|
||||
if lexbuf.Lexing.lex_curr_pos >= lexbuf.Lexing.lex_buffer_len then begin\n\
|
||||
if lexbuf.Lexing.lex_eof_reached then\n\
|
||||
256\n\
|
||||
else begin\n\
|
||||
lexbuf.Lexing.refill_buff lexbuf ;\n\
|
||||
__ocaml_lex_next_char lexbuf\n\
|
||||
end\n\
|
||||
end else begin\n\
|
||||
let i = lexbuf.Lexing.lex_curr_pos in\n\
|
||||
let c = lexbuf.Lexing.lex_buffer.[i] in\n\
|
||||
lexbuf.Lexing.lex_curr_pos <- i+1 ;\n\
|
||||
Char.code c\n\
|
||||
end\n\
|
||||
\n\
|
||||
"let rec __ocaml_lex_next_char lexbuf =\
|
||||
\n if lexbuf.Lexing.lex_curr_pos >= lexbuf.Lexing.lex_buffer_len then begin\
|
||||
\n if lexbuf.Lexing.lex_eof_reached then\
|
||||
\n 256\
|
||||
\n else begin\
|
||||
\n lexbuf.Lexing.refill_buff lexbuf ;\
|
||||
\n __ocaml_lex_next_char lexbuf\
|
||||
\n end\
|
||||
\n end else begin\
|
||||
\n let i = lexbuf.Lexing.lex_curr_pos in\
|
||||
\n let c = lexbuf.Lexing.lex_buffer.[i] in\
|
||||
\n lexbuf.Lexing.lex_curr_pos <- i+1 ;\
|
||||
\n Char.code c\
|
||||
\n end\
|
||||
\n\n\
|
||||
"
|
||||
|
||||
|
||||
|
|
@ -155,13 +155,13 @@ let output_automata oc auto =
|
|||
|
||||
let output_entry sourcefile ic oc tr e =
|
||||
let init_num, init_moves = e.auto_initial_state in
|
||||
fprintf oc "%s %alexbuf =\n\
|
||||
__ocaml_lex_init_lexbuf lexbuf %d; %a\n\
|
||||
let __ocaml_lex_result = __ocaml_lex_state%d lexbuf in\n\
|
||||
lexbuf.Lexing.lex_start_p <- lexbuf.Lexing.lex_curr_p;\n\
|
||||
lexbuf.Lexing.lex_curr_p <- {lexbuf.Lexing.lex_curr_p with\n\
|
||||
Lexing.pos_cnum = lexbuf.Lexing.lex_abs_pos + lexbuf.Lexing.lex_curr_pos};\n\
|
||||
match __ocaml_lex_result with\n"
|
||||
fprintf oc "%s %alexbuf =\
|
||||
\n __ocaml_lex_init_lexbuf lexbuf %d; %a\
|
||||
\n let __ocaml_lex_result = __ocaml_lex_state%d lexbuf in\
|
||||
\n lexbuf.Lexing.lex_start_p <- lexbuf.Lexing.lex_curr_p;\
|
||||
\n lexbuf.Lexing.lex_curr_p <- {lexbuf.Lexing.lex_curr_p with\
|
||||
\n Lexing.pos_cnum = lexbuf.Lexing.lex_abs_pos + lexbuf.Lexing.lex_curr_pos};\
|
||||
\n match __ocaml_lex_result with\n"
|
||||
e.auto_name output_args e.auto_args
|
||||
e.auto_mem_size (output_memory_actions " ") init_moves init_num ;
|
||||
List.iter
|
||||
|
|
|
|||
|
|
@ -59,6 +59,12 @@ the same
|
|||
.B \-I
|
||||
options that are passed to the compiler.
|
||||
.TP
|
||||
.BI \-ml\-synonym \ .ext
|
||||
Consider the given extension (with leading dot) to be a synonym for .ml.
|
||||
.TP
|
||||
.BI \-mli\-synonym \ .ext
|
||||
Consider the given extension (with leading dot) to be a synonym for .mli.
|
||||
.TP
|
||||
.B \-modules
|
||||
Output raw dependencies of the form
|
||||
.IR filename : \ Module1\ Module2 \ ... \ ModuleN
|
||||
|
|
|
|||
|
|
@ -683,6 +683,7 @@ let camlp4_import_list =
|
|||
"parsing/asttypes.mli";
|
||||
"parsing/parsetree.mli";
|
||||
"typing/outcometree.mli";
|
||||
"typing/oprint.ml";
|
||||
"myocamlbuild_config.ml";
|
||||
"utils/config.mlbuild"]
|
||||
;;
|
||||
|
|
|
|||
|
|
@ -25,10 +25,12 @@ module ANSI =
|
|||
let clear_to_eol oc () = fp oc "\027[K";;
|
||||
let bol oc () = fp oc "\r";;
|
||||
let get_columns () =
|
||||
try
|
||||
int_of_string (String.chomp (My_unix.run_and_read "tput cols"))
|
||||
with
|
||||
| Failure _ -> 80
|
||||
if Sys.os_type = "Unix" then
|
||||
try
|
||||
int_of_string (String.chomp (My_unix.run_and_read "tput cols"))
|
||||
with
|
||||
| Failure _ -> 80
|
||||
else 80
|
||||
end
|
||||
;;
|
||||
(* ***)
|
||||
|
|
|
|||
|
|
@ -109,7 +109,8 @@ let proceed () =
|
|||
if name = "_tags" then
|
||||
ignore (Configuration.parse_file ?dir path_name);
|
||||
|
||||
(String.length name > 0 && name.[0] <> '_' && name <> !Options.build_dir && not (List.mem name !Options.exclude_dirs))
|
||||
(List.mem name ["_oasis"] || (String.length name > 0 && name.[0] <> '_'))
|
||||
&& (name <> !Options.build_dir && not (List.mem name !Options.exclude_dirs))
|
||||
&& begin
|
||||
if path_name <> Filename.current_dir_name && Pathname.is_directory path_name then
|
||||
let tags = tags_of_pathname path_name in
|
||||
|
|
|
|||
|
|
@ -130,7 +130,7 @@ let byte_compile_ocaml_interf mli cmi env build =
|
|||
let byte_compile_ocaml_implem ?tag ml cmo env build =
|
||||
let ml = env ml and cmo = env cmo in
|
||||
prepare_compile build ml;
|
||||
ocamlc_c (tags_of_pathname ml++"implem"+++tag) ml cmo
|
||||
ocamlc_c (Tags.union (tags_of_pathname ml) (tags_of_pathname cmo)++"implem"+++tag) ml cmo
|
||||
|
||||
let cache_prepare_link = Hashtbl.create 107
|
||||
let rec prepare_link tag cmx extensions build =
|
||||
|
|
|
|||
|
|
@ -63,9 +63,14 @@ rule "target files"
|
|||
begin fun env build ->
|
||||
let itarget = env "%.itarget" in
|
||||
let dir = Pathname.dirname itarget in
|
||||
List.iter ignore_good
|
||||
(build (List.map (fun x -> [dir/x]) (string_list_of_file itarget)));
|
||||
Nop
|
||||
let targets = string_list_of_file itarget in
|
||||
List.iter ignore_good (build (List.map (fun x -> [dir/x]) targets));
|
||||
if !Options.make_links then
|
||||
let link x =
|
||||
Cmd (S [A"ln"; A"-sf"; P (!Options.build_dir/x); A Pathname.parent_dir_name]) in
|
||||
Seq (List.map (fun x -> link (dir/x)) targets)
|
||||
else
|
||||
Nop
|
||||
end;;
|
||||
|
||||
rule "ocaml: mli -> cmi"
|
||||
|
|
@ -244,6 +249,12 @@ rule "ocaml: p.cmxa & p.a -> p.cmxs & p.so"
|
|||
~deps:["%.p.cmxa"; x_p_a]
|
||||
(Ocaml_compiler.native_shared_library_link ~tags:["profile";"linkall"] "%.p.cmxa" "%.p.cmxs");;
|
||||
|
||||
rule "ocaml: cmx & o -> cmxs"
|
||||
~tags:["ocaml"; "native"; "shared"; "library"]
|
||||
~prods:["%.cmxs"]
|
||||
~deps:["%.cmx"; x_o]
|
||||
(Ocaml_compiler.native_shared_library_link "%.cmx" "%.cmxs");;
|
||||
|
||||
rule "ocaml: cmx & o -> cmxs & so"
|
||||
~tags:["ocaml"; "native"; "shared"; "library"]
|
||||
~prods:["%.cmxs"; x_dll]
|
||||
|
|
@ -406,7 +417,8 @@ end;;
|
|||
let () =
|
||||
if !Options.use_ocamlfind then begin
|
||||
(* Ocamlfind will link the archives for us. *)
|
||||
flag ["ocaml"; "link"] & A"-linkpkg";
|
||||
flag ["ocaml"; "link"; "program"] & A"-linkpkg";
|
||||
flag ["ocaml"; "link"; "toplevel"] & A"-linkpkg";
|
||||
|
||||
let all_tags = [
|
||||
["ocaml"; "byte"; "compile"];
|
||||
|
|
@ -441,7 +453,7 @@ let () =
|
|||
let () =
|
||||
pflag ["ocaml"; "native"; "compile"] "for-pack"
|
||||
(fun param -> S [A "-for-pack"; A param]);
|
||||
pflag ["ocaml"; "compile"] "inline"
|
||||
pflag ["ocaml"; "native"; "compile"] "inline"
|
||||
(fun param -> S [A "-inline"; A param]);
|
||||
pflag ["ocaml"; "compile"] "pp"
|
||||
(fun param -> S [A "-pp"; A param]);
|
||||
|
|
@ -503,6 +515,7 @@ flag ["ocaml"; "dtypes"; "compile"] (A "-dtypes");;
|
|||
flag ["ocaml"; "annot"; "compile"] (A "-annot");;
|
||||
flag ["ocaml"; "rectypes"; "compile"] (A "-rectypes");;
|
||||
flag ["ocaml"; "rectypes"; "infer_interface"] (A "-rectypes");;
|
||||
flag ["ocaml"; "rectypes"; "doc"] (A "-rectypes");;
|
||||
flag ["ocaml"; "linkall"; "link"] (A "-linkall");;
|
||||
flag ["ocaml"; "link"; "profile"; "native"] (A "-p");;
|
||||
flag ["ocaml"; "link"; "program"; "custom"; "byte"] (A "-custom");;
|
||||
|
|
@ -515,6 +528,8 @@ if not !Options.use_ocamlfind then begin
|
|||
flag ["ocaml"; "doc"; "thread"] (S[A"-I"; A"+threads"]);
|
||||
flag ["ocaml"; "link"; "thread"; "native"; "program"] (S[A "threads.cmxa"; A "-thread"]);
|
||||
flag ["ocaml"; "link"; "thread"; "byte"; "program"] (S[A "threads.cma"; A "-thread"])
|
||||
end else begin
|
||||
flag ["ocaml"; "link"; "thread"; "program"] (A "-thread")
|
||||
end;;
|
||||
|
||||
flag ["ocaml"; "compile"; "nopervasives"] (A"-nopervasives");;
|
||||
|
|
|
|||
|
|
@ -27,7 +27,7 @@ let ocamldep_command' tags =
|
|||
let menhir_ocamldep_command' tags ~menhir_spec out =
|
||||
let menhir = if !Options.ocamlyacc = N then V"MENHIR" else !Options.ocamlyacc in
|
||||
Cmd(S[menhir; T tags; A"--raw-depend";
|
||||
A"--ocamldep"; Quote (ocamldep_command' tags);
|
||||
A"--ocamldep"; Quote (ocamldep_command' Tags.empty);
|
||||
menhir_spec ; Sh ">"; Px out])
|
||||
|
||||
let menhir_ocamldep_command arg out env _build =
|
||||
|
|
|
|||
|
|
@ -1,7 +1,6 @@
|
|||
Log
|
||||
My_unix
|
||||
My_std
|
||||
Std_signatures
|
||||
Signatures
|
||||
Shell
|
||||
Display
|
||||
|
|
|
|||
|
|
@ -127,7 +127,7 @@ let add_to' rxs x =
|
|||
()
|
||||
let set_cmd rcmd = String (fun s -> rcmd := Sh s)
|
||||
let set_build_dir s = make_links := false; build_dir := s
|
||||
let spec =
|
||||
let spec = ref (
|
||||
Arg.align
|
||||
[
|
||||
"-version", Unit (fun () -> print_endline version; raise Exit_OK), " Display the version";
|
||||
|
|
@ -177,6 +177,7 @@ let spec =
|
|||
"-dont-catch-errors", Clear catch_errors, " Don't catch and display exceptions (useful to display the call stack)";
|
||||
"-just-plugin", Set just_plugin, " Just build myocamlbuild.ml";
|
||||
"-byte-plugin", Clear native_plugin, " Don't use a native plugin but bytecode";
|
||||
"-plugin-option", String ignore, " Use the option only when plugin is run";
|
||||
"-sanitization-script", Set_string sanitization_script, " Change the file name for the generated sanitization script";
|
||||
"-no-sanitize", Clear sanitize, " Do not generate sanitization script";
|
||||
"-nothing-should-be-rebuilt", Set nothing_should_be_rebuilt, " Fail if something needs to be rebuilt";
|
||||
|
|
@ -195,6 +196,7 @@ let spec =
|
|||
"-ocamlc", set_cmd ocamlc, "<command> Set the OCaml bytecode compiler";
|
||||
"-ocamlopt", set_cmd ocamlopt, "<command> Set the OCaml native compiler";
|
||||
"-ocamldep", set_cmd ocamldep, "<command> Set the OCaml dependency tool";
|
||||
"-ocamldoc", set_cmd ocamldoc, "<command> Set the OCaml documentation generator";
|
||||
"-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";
|
||||
|
|
@ -205,7 +207,10 @@ let spec =
|
|||
|
||||
"--", Rest (fun x -> program_to_execute := true; add_to' program_args_internal x),
|
||||
" Stop argument processing, remaining arguments are given to the user program";
|
||||
]
|
||||
])
|
||||
|
||||
let add x =
|
||||
spec := !spec @ [x]
|
||||
|
||||
let targets = ref []
|
||||
let ocaml_libs = ref []
|
||||
|
|
@ -226,7 +231,7 @@ let init () =
|
|||
let anon_fun = add_to' targets_internal in
|
||||
let usage_msg = sprintf "Usage %s [options] <target>" Sys.argv.(0) in
|
||||
let argv' = Array.concat [Sys.argv; [|dummy|]] in
|
||||
parse_argv argv' spec anon_fun usage_msg;
|
||||
parse_argv argv' !spec anon_fun usage_msg;
|
||||
Shell.mkdir_p !build_dir;
|
||||
|
||||
let () =
|
||||
|
|
|
|||
|
|
@ -103,8 +103,9 @@ module Make(U:sig end) =
|
|||
Shell.chdir Pathname.pwd;
|
||||
if not !Options.just_plugin then
|
||||
let runner = if !Options.native_plugin then N else !Options.ocamlrun in
|
||||
let argv = List.tl (Array.to_list Sys.argv) in
|
||||
let spec = S[runner; P(!Options.build_dir/plugin^(!Options.exe));
|
||||
A"-no-plugin"; atomize (List.tl (Array.to_list Sys.argv))] in
|
||||
A"-no-plugin"; atomize (List.filter (fun s -> s <> "-plugin-option") argv)] in
|
||||
let () = Log.finish () in
|
||||
raise (Exit_silently_with_code (sys_command (Command.string_of_command_spec spec)))
|
||||
end
|
||||
|
|
|
|||
|
|
@ -35,7 +35,7 @@ module type LIST = sig
|
|||
val union : 'a list -> 'a list -> 'a list
|
||||
|
||||
(* Original functions *)
|
||||
include Std_signatures.LIST
|
||||
include module type of List
|
||||
end
|
||||
|
||||
module type STRING = sig
|
||||
|
|
@ -89,7 +89,7 @@ module type STRING = sig
|
|||
val explode : string -> char list
|
||||
|
||||
(** The following are original functions from the [String] module. *)
|
||||
include Std_signatures.STRING
|
||||
include module type of String
|
||||
end
|
||||
|
||||
module type TAGS = sig
|
||||
|
|
@ -401,6 +401,8 @@ module type OPTIONS = sig
|
|||
val ext_lib : string ref
|
||||
val ext_dll : string ref
|
||||
val exe : string ref
|
||||
|
||||
val add : string * Arg.spec * string -> unit
|
||||
end
|
||||
|
||||
module type ARCH = sig
|
||||
|
|
|
|||
|
|
@ -1,94 +0,0 @@
|
|||
(***********************************************************************)
|
||||
(* ocamlbuild *)
|
||||
(* *)
|
||||
(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
|
||||
(* *)
|
||||
(* Copyright 2007 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. *)
|
||||
(* *)
|
||||
(***********************************************************************)
|
||||
|
||||
|
||||
(* Original author: Nicolas Pouillard *)
|
||||
(** Some signatures from the standard library. *)
|
||||
|
||||
module type LIST = sig
|
||||
val length : 'a list -> int
|
||||
val hd : 'a list -> 'a
|
||||
val tl : 'a list -> 'a list
|
||||
val nth : 'a list -> int -> 'a
|
||||
val rev : 'a list -> 'a list
|
||||
val append : 'a list -> 'a list -> 'a list
|
||||
val rev_append : 'a list -> 'a list -> 'a list
|
||||
val concat : 'a list list -> 'a list
|
||||
val flatten : 'a list list -> 'a list
|
||||
val iter : ('a -> unit) -> 'a list -> unit
|
||||
val map : ('a -> 'b) -> 'a list -> 'b list
|
||||
val rev_map : ('a -> 'b) -> 'a list -> 'b list
|
||||
val fold_left : ('a -> 'b -> 'a) -> 'a -> 'b list -> 'a
|
||||
val fold_right : ('a -> 'b -> 'b) -> 'a list -> 'b -> 'b
|
||||
val iter2 : ('a -> 'b -> unit) -> 'a list -> 'b list -> unit
|
||||
val map2 : ('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list
|
||||
val rev_map2 : ('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list
|
||||
val fold_left2 : ('a -> 'b -> 'c -> 'a) -> 'a -> 'b list -> 'c list -> 'a
|
||||
val fold_right2 :
|
||||
('a -> 'b -> 'c -> 'c) -> 'a list -> 'b list -> 'c -> 'c
|
||||
val for_all : ('a -> bool) -> 'a list -> bool
|
||||
val exists : ('a -> bool) -> 'a list -> bool
|
||||
val for_all2 : ('a -> 'b -> bool) -> 'a list -> 'b list -> bool
|
||||
val exists2 : ('a -> 'b -> bool) -> 'a list -> 'b list -> bool
|
||||
val mem : 'a -> 'a list -> bool
|
||||
val memq : 'a -> 'a list -> bool
|
||||
val find : ('a -> bool) -> 'a list -> 'a
|
||||
val filter : ('a -> bool) -> 'a list -> 'a list
|
||||
val find_all : ('a -> bool) -> 'a list -> 'a list
|
||||
val partition : ('a -> bool) -> 'a list -> 'a list * 'a list
|
||||
val assoc : 'a -> ('a * 'b) list -> 'b
|
||||
val assq : 'a -> ('a * 'b) list -> 'b
|
||||
val mem_assoc : 'a -> ('a * 'b) list -> bool
|
||||
val mem_assq : 'a -> ('a * 'b) list -> bool
|
||||
val remove_assoc : 'a -> ('a * 'b) list -> ('a * 'b) list
|
||||
val remove_assq : 'a -> ('a * 'b) list -> ('a * 'b) list
|
||||
val split : ('a * 'b) list -> 'a list * 'b list
|
||||
val combine : 'a list -> 'b list -> ('a * 'b) list
|
||||
val sort : ('a -> 'a -> int) -> 'a list -> 'a list
|
||||
val stable_sort : ('a -> 'a -> int) -> 'a list -> 'a list
|
||||
val fast_sort : ('a -> 'a -> int) -> 'a list -> 'a list
|
||||
val merge : ('a -> 'a -> int) -> 'a list -> 'a list -> 'a list
|
||||
end
|
||||
|
||||
module type STRING = sig
|
||||
external length : string -> int = "%string_length"
|
||||
external get : string -> int -> char = "%string_safe_get"
|
||||
external set : string -> int -> char -> unit = "%string_safe_set"
|
||||
external create : int -> string = "caml_create_string"
|
||||
val make : int -> char -> string
|
||||
val copy : string -> string
|
||||
val sub : string -> int -> int -> string
|
||||
val fill : string -> int -> int -> char -> unit
|
||||
val blit : string -> int -> string -> int -> int -> unit
|
||||
val concat : string -> string list -> string
|
||||
val iter : (char -> unit) -> string -> unit
|
||||
val escaped : string -> string
|
||||
val index : string -> char -> int
|
||||
val rindex : string -> char -> int
|
||||
val index_from : string -> int -> char -> int
|
||||
val rindex_from : string -> int -> char -> int
|
||||
val contains : string -> char -> bool
|
||||
val contains_from : string -> int -> char -> bool
|
||||
val rcontains_from : string -> int -> char -> bool
|
||||
val uppercase : string -> string
|
||||
val lowercase : string -> string
|
||||
val capitalize : string -> string
|
||||
val uncapitalize : string -> string
|
||||
type t = string
|
||||
val compare : t -> t -> int
|
||||
external unsafe_get : string -> int -> char = "%string_unsafe_get"
|
||||
external unsafe_set : string -> int -> char -> unit
|
||||
= "%string_unsafe_set"
|
||||
external unsafe_blit : string -> int -> string -> int -> int -> unit
|
||||
= "caml_blit_string" "noalloc"
|
||||
external unsafe_fill : string -> int -> int -> char -> unit
|
||||
= "caml_fill_string" "noalloc"
|
||||
end
|
||||
|
|
@ -31,7 +31,7 @@ OCAMLPP=-pp './remove_DEBUG'
|
|||
MKDIR=mkdir -p
|
||||
CP=cp -f
|
||||
OCAMLDOC=ocamldoc
|
||||
OCAMLDOC_RUN=./ocamldoc.opt #sh ./runocamldoc $(SUPPORTS_SHARED_LIBRARIES)
|
||||
OCAMLDOC_RUN=sh ./runocamldoc $(SUPPORTS_SHARED_LIBRARIES)
|
||||
OCAMLDOC_OPT=$(OCAMLDOC).opt
|
||||
OCAMLDOC_LIBCMA=odoc_info.cma
|
||||
OCAMLDOC_LIBCMI=odoc_info.cmi
|
||||
|
|
@ -194,14 +194,13 @@ STDLIB_MLIS=../stdlib/*.mli \
|
|||
../otherlibs/bigarray/bigarray.mli \
|
||||
../otherlibs/num/num.mli
|
||||
|
||||
all: exe lib generators
|
||||
all: exe lib generators manpages
|
||||
|
||||
exe: $(OCAMLDOC)
|
||||
lib: $(OCAMLDOC_LIBCMA) $(OCAMLDOC_LIBCMI) $(ODOC_TEST)
|
||||
generators: $(GENERATORS_CMOS)
|
||||
|
||||
opt.opt: exeopt libopt generatorsopt
|
||||
$(MAKE) manpages
|
||||
exeopt: $(OCAMLDOC_OPT)
|
||||
libopt: $(OCAMLDOC_LIBCMXA) $(OCAMLDOC_LIBCMI)
|
||||
generatorsopt: $(GENERATORS_CMXS)
|
||||
|
|
|
|||
|
|
@ -39,6 +39,7 @@ let analyse_merge_options s =
|
|||
(M.merge_version, [Odoc_types.Merge_version]) ;
|
||||
(M.merge_see, [Odoc_types.Merge_see]) ;
|
||||
(M.merge_since, [Odoc_types.Merge_since]) ;
|
||||
(M.merge_before, [Odoc_types.Merge_before]) ;
|
||||
(M.merge_deprecated, [Odoc_types.Merge_deprecated]) ;
|
||||
(M.merge_param, [Odoc_types.Merge_param]) ;
|
||||
(M.merge_raised_exception, [Odoc_types.Merge_raised_exception]) ;
|
||||
|
|
@ -83,7 +84,7 @@ let add_hidden_modules s =
|
|||
let set_generator (g : Odoc_gen.generator) = current_generator := Some g
|
||||
|
||||
(** The default option list *)
|
||||
let options = ref [
|
||||
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 ;
|
||||
|
|
@ -155,7 +156,8 @@ let options = ref [
|
|||
"-css-style", Arg.String (fun s -> Odoc_html.css_style := Some s), M.css_style ;
|
||||
"-index-only", Arg.Set Odoc_html.index_only, M.index_only ;
|
||||
"-colorize-code", Arg.Set Odoc_html.colorize_code, M.colorize_code ;
|
||||
"-short-functors", Arg.Set Odoc_html.html_short_functors, M.html_short_functors ^
|
||||
"-short-functors", Arg.Set Odoc_html.html_short_functors, M.html_short_functors ;
|
||||
"-charset", Arg.Set_string Odoc_html.charset, (M.charset !Odoc_html.charset)^
|
||||
"\n\n *** LaTeX options ***\n";
|
||||
|
||||
(* latex only options *)
|
||||
|
|
@ -206,7 +208,34 @@ let options = ref [
|
|||
|
||||
]
|
||||
|
||||
let options = ref default_options
|
||||
|
||||
let modified_options () =
|
||||
!options != default_options
|
||||
|
||||
let append_last_doc suffix =
|
||||
match List.rev !options with
|
||||
| (key, spec, doc) :: tl ->
|
||||
options := List.rev ((key, spec, doc ^ suffix) :: tl)
|
||||
| [] -> ()
|
||||
|
||||
(** The help option list, overriding the default ones from the Arg module *)
|
||||
let help_options = ref []
|
||||
let help_action () =
|
||||
let msg =
|
||||
Arg.usage_string
|
||||
(!options @ !help_options)
|
||||
(M.usage ^ M.options_are) in
|
||||
print_string msg
|
||||
let () =
|
||||
help_options := [
|
||||
"-help", Arg.Unit help_action, M.help ;
|
||||
"--help", Arg.Unit help_action, M.help
|
||||
]
|
||||
|
||||
let add_option o =
|
||||
if not (modified_options ()) then
|
||||
append_last_doc "\n *** custom generator options ***\n";
|
||||
let (s,_,_) = o in
|
||||
let rec iter = function
|
||||
[] -> [o]
|
||||
|
|
@ -234,7 +263,9 @@ let parse () =
|
|||
in
|
||||
Odoc_global.files := !Odoc_global.files @ [sf]
|
||||
in
|
||||
let _ = Arg.parse !options
|
||||
if modified_options () then append_last_doc "\n";
|
||||
let options = !options @ !help_options in
|
||||
let _ = Arg.parse options
|
||||
anonymous
|
||||
(M.usage^M.options_are)
|
||||
in
|
||||
|
|
|
|||
|
|
@ -28,6 +28,7 @@ let css_style = ref None
|
|||
let index_only = ref false
|
||||
let colorize_code = ref false
|
||||
let html_short_functors = ref false
|
||||
let charset = ref "iso-8859-1"
|
||||
|
||||
|
||||
(** The functions used for naming files and html marks.*)
|
||||
|
|
@ -538,28 +539,34 @@ class virtual info =
|
|||
match l with
|
||||
[] -> ()
|
||||
| _ ->
|
||||
bp b "<b>%s:</b> %s<br>\n"
|
||||
Odoc_messages.authors
|
||||
(String.concat ", " l)
|
||||
bp b "<b>%s:</b> " Odoc_messages.authors;
|
||||
self#html_of_text b [Raw (String.concat ", " l)];
|
||||
bs b "<br>\n"
|
||||
|
||||
(** Print html code for the given optional version information.*)
|
||||
method html_of_version_opt b v_opt =
|
||||
match v_opt with
|
||||
None -> ()
|
||||
| Some v ->
|
||||
bp b "<b>%s:</b> %s<br>\n" Odoc_messages.version v
|
||||
bp b "<b>%s:</b> " Odoc_messages.version;
|
||||
self#html_of_text b [Raw v];
|
||||
bs b "<br>\n"
|
||||
|
||||
(** Print html code for the given optional since information.*)
|
||||
method html_of_since_opt b s_opt =
|
||||
match s_opt with
|
||||
None -> ()
|
||||
| Some s ->
|
||||
bp b "<b>%s</b> %s<br>\n" Odoc_messages.since s
|
||||
bp b "<b>%s</b> " Odoc_messages.since;
|
||||
self#html_of_text b [Raw s];
|
||||
bs b "<br>\n"
|
||||
|
||||
(** Print html code for the given "before" information.*)
|
||||
method html_of_before b l =
|
||||
let f (v, text) =
|
||||
bp b "<b>%s %s </b> " Odoc_messages.before v;
|
||||
bp b "<b>%s " Odoc_messages.before;
|
||||
self#html_of_text b [Raw v];
|
||||
bs b " </b> ";
|
||||
self#html_of_text b text;
|
||||
bs b "<br>\n"
|
||||
in
|
||||
|
|
@ -734,8 +741,10 @@ class html =
|
|||
|
||||
val mutable doctype =
|
||||
"<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\">\n"
|
||||
val mutable character_encoding =
|
||||
"<meta content=\"text/html; charset=iso-8859-1\" http-equiv=\"Content-Type\">\n"
|
||||
method character_encoding () =
|
||||
Printf.sprintf
|
||||
"<meta content=\"text/html; charset=%s\" http-equiv=\"Content-Type\">\n"
|
||||
!charset
|
||||
|
||||
(** The default style options. *)
|
||||
val mutable default_style_options =
|
||||
|
|
@ -943,7 +952,7 @@ class html =
|
|||
in
|
||||
bs b "<head>\n";
|
||||
bs b style;
|
||||
bs b character_encoding ;
|
||||
bs b (self#character_encoding ()) ;
|
||||
bs b "<link rel=\"Start\" href=\"";
|
||||
bs b self#index;
|
||||
bs b "\">\n" ;
|
||||
|
|
|
|||
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue