diff options
| author | Alain Frisch <alain@frisch.fr> | 2014-09-04 16:11:12 +0000 |
|---|---|---|
| committer | Alain Frisch <alain@frisch.fr> | 2014-09-04 16:11:12 +0000 |
| commit | 378a967cb7436c5eee41262e07e26a65b7da6c74 (patch) | |
| tree | 6b1e1f339127077657d4659a8030d18dd563dd0c | |
| parent | e0957377188e4b04fef7fb3f48f1b3ce3b101018 (diff) | |
| parent | a360747bc2e98e31b478898ff128bb91fcc9afbe (diff) | |
| download | ocaml-378a967cb7436c5eee41262e07e26a65b7da6c74.tar.gz | |
Sync with trunk.
git-svn-id: http://caml.inria.fr/svn/ocaml/branches/constructors_with_record3@15190 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02
290 files changed, 3514 insertions, 1617 deletions
@@ -189,11 +189,11 @@ typing/env.cmx : utils/warnings.cmx typing/types.cmx utils/tbl.cmx \ typing/cmi_format.cmx utils/clflags.cmx typing/btype.cmx \ parsing/asttypes.cmi typing/env.cmi typing/envaux.cmo : typing/types.cmi typing/subst.cmi typing/printtyp.cmi \ - typing/path.cmi typing/mtype.cmi utils/misc.cmi typing/ident.cmi \ - typing/env.cmi parsing/asttypes.cmi typing/envaux.cmi + typing/path.cmi utils/misc.cmi typing/ident.cmi typing/env.cmi \ + parsing/asttypes.cmi typing/envaux.cmi typing/envaux.cmx : typing/types.cmx typing/subst.cmx typing/printtyp.cmx \ - typing/path.cmx typing/mtype.cmx utils/misc.cmx typing/ident.cmx \ - typing/env.cmx parsing/asttypes.cmi typing/envaux.cmi + typing/path.cmx utils/misc.cmx typing/ident.cmx typing/env.cmx \ + parsing/asttypes.cmi typing/envaux.cmi typing/ident.cmo : typing/ident.cmi typing/ident.cmx : typing/ident.cmi typing/includeclass.cmo : typing/types.cmi typing/printtyp.cmi \ @@ -623,8 +623,10 @@ asmcomp/split.cmi : asmcomp/mach.cmi asmcomp/strmatch.cmi : asmcomp/cmm.cmi asmcomp/CSE.cmo : asmcomp/mach.cmi asmcomp/CSEgen.cmi asmcomp/arch.cmo asmcomp/CSE.cmx : asmcomp/mach.cmx asmcomp/CSEgen.cmx asmcomp/arch.cmx -asmcomp/CSEgen.cmo : asmcomp/reg.cmi asmcomp/mach.cmi asmcomp/CSEgen.cmi -asmcomp/CSEgen.cmx : asmcomp/reg.cmx asmcomp/mach.cmx asmcomp/CSEgen.cmi +asmcomp/CSEgen.cmo : asmcomp/reg.cmi asmcomp/proc.cmi asmcomp/mach.cmi \ + asmcomp/CSEgen.cmi +asmcomp/CSEgen.cmx : asmcomp/reg.cmx asmcomp/proc.cmx asmcomp/mach.cmx \ + asmcomp/CSEgen.cmi asmcomp/arch.cmo : asmcomp/arch.cmx : asmcomp/asmgen.cmo : bytecomp/translmod.cmi asmcomp/split.cmi \ @@ -864,8 +866,7 @@ driver/compile.cmo : utils/warnings.cmi typing/typemod.cmi \ parsing/printast.cmi parsing/pprintast.cmi driver/pparse.cmi \ utils/misc.cmi parsing/location.cmi typing/includemod.cmi typing/env.cmi \ bytecomp/emitcode.cmi driver/compmisc.cmi driver/compenv.cmi \ - utils/clflags.cmi utils/ccomp.cmi bytecomp/bytegen.cmi \ - parsing/ast_mapper.cmi driver/compile.cmi + utils/clflags.cmi utils/ccomp.cmi bytecomp/bytegen.cmi driver/compile.cmi driver/compile.cmx : utils/warnings.cmx typing/typemod.cmx \ typing/typedtree.cmx typing/typecore.cmx bytecomp/translmod.cmx \ typing/stypes.cmx bytecomp/simplif.cmx typing/printtyped.cmx \ @@ -873,8 +874,7 @@ driver/compile.cmx : utils/warnings.cmx typing/typemod.cmx \ parsing/printast.cmx parsing/pprintast.cmx driver/pparse.cmx \ utils/misc.cmx parsing/location.cmx typing/includemod.cmx typing/env.cmx \ bytecomp/emitcode.cmx driver/compmisc.cmx driver/compenv.cmx \ - utils/clflags.cmx utils/ccomp.cmx bytecomp/bytegen.cmx \ - parsing/ast_mapper.cmx driver/compile.cmi + utils/clflags.cmx utils/ccomp.cmx bytecomp/bytegen.cmx driver/compile.cmi driver/compmisc.cmo : typing/typemod.cmi utils/misc.cmi \ parsing/longident.cmi parsing/location.cmi typing/ident.cmi \ typing/env.cmi utils/config.cmi driver/compenv.cmi utils/clflags.cmi \ @@ -904,8 +904,7 @@ driver/optcompile.cmo : utils/warnings.cmi typing/typemod.cmi \ parsing/pprintast.cmi driver/pparse.cmi utils/misc.cmi \ typing/includemod.cmi typing/env.cmi utils/config.cmi driver/compmisc.cmi \ asmcomp/compilenv.cmi driver/compenv.cmi utils/clflags.cmi \ - utils/ccomp.cmi parsing/ast_mapper.cmi asmcomp/asmgen.cmi \ - driver/optcompile.cmi + utils/ccomp.cmi asmcomp/asmgen.cmi driver/optcompile.cmi driver/optcompile.cmx : utils/warnings.cmx typing/typemod.cmx \ typing/typedtree.cmx typing/typecore.cmx bytecomp/translmod.cmx \ typing/stypes.cmx bytecomp/simplif.cmx typing/printtyped.cmx \ @@ -913,8 +912,7 @@ driver/optcompile.cmx : utils/warnings.cmx typing/typemod.cmx \ parsing/pprintast.cmx driver/pparse.cmx utils/misc.cmx \ typing/includemod.cmx typing/env.cmx utils/config.cmx driver/compmisc.cmx \ asmcomp/compilenv.cmx driver/compenv.cmx utils/clflags.cmx \ - utils/ccomp.cmx parsing/ast_mapper.cmx asmcomp/asmgen.cmx \ - driver/optcompile.cmi + utils/ccomp.cmx asmcomp/asmgen.cmx driver/optcompile.cmi driver/opterrors.cmo : parsing/location.cmi driver/opterrors.cmi driver/opterrors.cmx : parsing/location.cmx driver/opterrors.cmi driver/optmain.cmo : utils/warnings.cmi asmcomp/printmach.cmi \ @@ -930,12 +928,10 @@ driver/optmain.cmx : utils/warnings.cmx asmcomp/printmach.cmx \ asmcomp/asmlink.cmx asmcomp/asmlibrarian.cmx asmcomp/arch.cmx \ driver/optmain.cmi driver/pparse.cmo : parsing/parsetree.cmi parsing/parse.cmi utils/misc.cmi \ - parsing/longident.cmi parsing/location.cmi utils/config.cmi \ - utils/clflags.cmi utils/ccomp.cmi parsing/asttypes.cmi \ + parsing/location.cmi utils/config.cmi utils/clflags.cmi utils/ccomp.cmi \ parsing/ast_mapper.cmi parsing/ast_helper.cmi driver/pparse.cmi driver/pparse.cmx : parsing/parsetree.cmi parsing/parse.cmx utils/misc.cmx \ - parsing/longident.cmx parsing/location.cmx utils/config.cmx \ - utils/clflags.cmx utils/ccomp.cmx parsing/asttypes.cmi \ + parsing/location.cmx utils/config.cmx utils/clflags.cmx utils/ccomp.cmx \ parsing/ast_mapper.cmx parsing/ast_helper.cmx driver/pparse.cmi toplevel/genprintval.cmi : typing/types.cmi typing/path.cmi \ typing/outcometree.cmi typing/env.cmi @@ -1000,13 +996,11 @@ toplevel/opttoploop.cmx : utils/warnings.cmx typing/types.cmx \ toplevel/opttopmain.cmo : utils/warnings.cmi asmcomp/printmach.cmi \ toplevel/opttoploop.cmi toplevel/opttopdirs.cmi utils/misc.cmi \ driver/main_args.cmi parsing/location.cmi utils/config.cmi \ - driver/compenv.cmi utils/clflags.cmi parsing/ast_mapper.cmi \ - toplevel/opttopmain.cmi + driver/compenv.cmi utils/clflags.cmi toplevel/opttopmain.cmi toplevel/opttopmain.cmx : utils/warnings.cmx asmcomp/printmach.cmx \ toplevel/opttoploop.cmx toplevel/opttopdirs.cmx utils/misc.cmx \ driver/main_args.cmx parsing/location.cmx utils/config.cmx \ - driver/compenv.cmx utils/clflags.cmx parsing/ast_mapper.cmx \ - toplevel/opttopmain.cmi + driver/compenv.cmx utils/clflags.cmx toplevel/opttopmain.cmi toplevel/opttopstart.cmo : toplevel/opttopmain.cmi toplevel/opttopstart.cmx : toplevel/opttopmain.cmx toplevel/topdirs.cmo : utils/warnings.cmi typing/typetexp.cmi \ @@ -1056,11 +1050,11 @@ toplevel/toploop.cmx : utils/warnings.cmx typing/types.cmx \ toplevel/topmain.cmo : utils/warnings.cmi toplevel/toploop.cmi \ toplevel/topdirs.cmi utils/misc.cmi driver/main_args.cmi \ parsing/location.cmi utils/config.cmi driver/compenv.cmi \ - utils/clflags.cmi parsing/ast_mapper.cmi toplevel/topmain.cmi + utils/clflags.cmi toplevel/topmain.cmi toplevel/topmain.cmx : utils/warnings.cmx toplevel/toploop.cmx \ toplevel/topdirs.cmx utils/misc.cmx driver/main_args.cmx \ parsing/location.cmx utils/config.cmx driver/compenv.cmx \ - utils/clflags.cmx parsing/ast_mapper.cmx toplevel/topmain.cmi + utils/clflags.cmx toplevel/topmain.cmi toplevel/topstart.cmo : toplevel/topmain.cmi toplevel/topstart.cmx : toplevel/topmain.cmx toplevel/trace.cmo : typing/types.cmi toplevel/toploop.cmi \ diff --git a/.gitignore b/.gitignore index 2817041cf7..d36195a282 100644 --- a/.gitignore +++ b/.gitignore @@ -1,6 +1,3 @@ -# This file has been automatically generated using `git svn show-ignore > .gitignore` -# from trunk@14716 (Thu May 1 09:28:35 2014). -# Do not hesitate to refresh it from time to time. # / /*.o @@ -1222,6 +1219,27 @@ /testsuite/tests/basic-manyargs/.depend.nt /testsuite/tests/basic-manyargs/.DS_Store +# /testsuite/tests/basic-modules/ +/testsuite/tests/basic-modules/*.o +/testsuite/tests/basic-modules/*.a +/testsuite/tests/basic-modules/*.so +/testsuite/tests/basic-modules/*.obj +/testsuite/tests/basic-modules/*.lib +/testsuite/tests/basic-modules/*.dll +/testsuite/tests/basic-modules/*.cm[ioxat] +/testsuite/tests/basic-modules/*.cmx[as] +/testsuite/tests/basic-modules/*.cmti +/testsuite/tests/basic-modules/*.annot +/testsuite/tests/basic-modules/*.result +/testsuite/tests/basic-modules/*.byte +/testsuite/tests/basic-modules/*.native +/testsuite/tests/basic-modules/program +/testsuite/tests/basic-modules/*.exe +/testsuite/tests/basic-modules/*.exe.manifest +/testsuite/tests/basic-modules/.depend +/testsuite/tests/basic-modules/.depend.nt +/testsuite/tests/basic-modules/.DS_Store + # /testsuite/tests/basic-more/ /testsuite/tests/basic-more/*.o /testsuite/tests/basic-more/*.a @@ -1341,6 +1359,27 @@ /testsuite/tests/exotic-syntax/.depend.nt /testsuite/tests/exotic-syntax/.DS_Store +# /testsuite/tests/formats-transition/ +/testsuite/tests/formats-transition/*.o +/testsuite/tests/formats-transition/*.a +/testsuite/tests/formats-transition/*.so +/testsuite/tests/formats-transition/*.obj +/testsuite/tests/formats-transition/*.lib +/testsuite/tests/formats-transition/*.dll +/testsuite/tests/formats-transition/*.cm[ioxat] +/testsuite/tests/formats-transition/*.cmx[as] +/testsuite/tests/formats-transition/*.cmti +/testsuite/tests/formats-transition/*.annot +/testsuite/tests/formats-transition/*.result +/testsuite/tests/formats-transition/*.byte +/testsuite/tests/formats-transition/*.native +/testsuite/tests/formats-transition/program +/testsuite/tests/formats-transition/*.exe +/testsuite/tests/formats-transition/*.exe.manifest +/testsuite/tests/formats-transition/.depend +/testsuite/tests/formats-transition/.depend.nt +/testsuite/tests/formats-transition/.DS_Store + # /testsuite/tests/gc-roots/ /testsuite/tests/gc-roots/*.o /testsuite/tests/gc-roots/*.a @@ -1799,6 +1838,48 @@ /testsuite/tests/lib-threads/.DS_Store /testsuite/tests/lib-threads/*.byt +# /testsuite/tests/match-exception/ +/testsuite/tests/match-exception/*.o +/testsuite/tests/match-exception/*.a +/testsuite/tests/match-exception/*.so +/testsuite/tests/match-exception/*.obj +/testsuite/tests/match-exception/*.lib +/testsuite/tests/match-exception/*.dll +/testsuite/tests/match-exception/*.cm[ioxat] +/testsuite/tests/match-exception/*.cmx[as] +/testsuite/tests/match-exception/*.cmti +/testsuite/tests/match-exception/*.annot +/testsuite/tests/match-exception/*.result +/testsuite/tests/match-exception/*.byte +/testsuite/tests/match-exception/*.native +/testsuite/tests/match-exception/program +/testsuite/tests/match-exception/*.exe +/testsuite/tests/match-exception/*.exe.manifest +/testsuite/tests/match-exception/.depend +/testsuite/tests/match-exception/.depend.nt +/testsuite/tests/match-exception/.DS_Store + +# /testsuite/tests/match-exception-warnings/ +/testsuite/tests/match-exception-warnings/*.o +/testsuite/tests/match-exception-warnings/*.a +/testsuite/tests/match-exception-warnings/*.so +/testsuite/tests/match-exception-warnings/*.obj +/testsuite/tests/match-exception-warnings/*.lib +/testsuite/tests/match-exception-warnings/*.dll +/testsuite/tests/match-exception-warnings/*.cm[ioxat] +/testsuite/tests/match-exception-warnings/*.cmx[as] +/testsuite/tests/match-exception-warnings/*.cmti +/testsuite/tests/match-exception-warnings/*.annot +/testsuite/tests/match-exception-warnings/*.result +/testsuite/tests/match-exception-warnings/*.byte +/testsuite/tests/match-exception-warnings/*.native +/testsuite/tests/match-exception-warnings/program +/testsuite/tests/match-exception-warnings/*.exe +/testsuite/tests/match-exception-warnings/*.exe.manifest +/testsuite/tests/match-exception-warnings/.depend +/testsuite/tests/match-exception-warnings/.depend.nt +/testsuite/tests/match-exception-warnings/.DS_Store + # /testsuite/tests/misc/ /testsuite/tests/misc/*.o /testsuite/tests/misc/*.a @@ -2034,6 +2115,51 @@ /testsuite/tests/tool-debugger/.DS_Store /testsuite/tests/tool-debugger/compiler-libs +# /testsuite/tests/tool-debugger/basic/ +/testsuite/tests/tool-debugger/basic/*.o +/testsuite/tests/tool-debugger/basic/*.a +/testsuite/tests/tool-debugger/basic/*.so +/testsuite/tests/tool-debugger/basic/*.obj +/testsuite/tests/tool-debugger/basic/*.lib +/testsuite/tests/tool-debugger/basic/*.dll +/testsuite/tests/tool-debugger/basic/*.cm[ioxat] +/testsuite/tests/tool-debugger/basic/*.cmx[as] +/testsuite/tests/tool-debugger/basic/*.cmti +/testsuite/tests/tool-debugger/basic/*.annot +/testsuite/tests/tool-debugger/basic/*.result +/testsuite/tests/tool-debugger/basic/*.byte +/testsuite/tests/tool-debugger/basic/*.native +/testsuite/tests/tool-debugger/basic/program +/testsuite/tests/tool-debugger/basic/*.exe +/testsuite/tests/tool-debugger/basic/*.exe.manifest +/testsuite/tests/tool-debugger/basic/.depend +/testsuite/tests/tool-debugger/basic/.depend.nt +/testsuite/tests/tool-debugger/basic/.DS_Store +/testsuite/tests/tool-debugger/basic/compiler-libs + +# /testsuite/tests/tool-debugger/find-artifacts/ +/testsuite/tests/tool-debugger/find-artifacts/*.o +/testsuite/tests/tool-debugger/find-artifacts/*.a +/testsuite/tests/tool-debugger/find-artifacts/*.so +/testsuite/tests/tool-debugger/find-artifacts/*.obj +/testsuite/tests/tool-debugger/find-artifacts/*.lib +/testsuite/tests/tool-debugger/find-artifacts/*.dll +/testsuite/tests/tool-debugger/find-artifacts/*.cm[ioxat] +/testsuite/tests/tool-debugger/find-artifacts/*.cmx[as] +/testsuite/tests/tool-debugger/find-artifacts/*.cmti +/testsuite/tests/tool-debugger/find-artifacts/*.annot +/testsuite/tests/tool-debugger/find-artifacts/*.result +/testsuite/tests/tool-debugger/find-artifacts/*.byte +/testsuite/tests/tool-debugger/find-artifacts/*.native +/testsuite/tests/tool-debugger/find-artifacts/program +/testsuite/tests/tool-debugger/find-artifacts/*.exe +/testsuite/tests/tool-debugger/find-artifacts/*.exe.manifest +/testsuite/tests/tool-debugger/find-artifacts/.depend +/testsuite/tests/tool-debugger/find-artifacts/.depend.nt +/testsuite/tests/tool-debugger/find-artifacts/.DS_Store +/testsuite/tests/tool-debugger/find-artifacts/compiler-libs +/testsuite/tests/tool-debugger/find-artifacts/out + # /testsuite/tests/tool-lexyacc/ /testsuite/tests/tool-lexyacc/*.o /testsuite/tests/tool-lexyacc/*.a @@ -2091,6 +2217,48 @@ /testsuite/tests/tool-ocamldoc/*.css /testsuite/tests/tool-ocamldoc/ocamldoc.out +# /testsuite/tests/tool-toplevel/ +/testsuite/tests/tool-toplevel/*.o +/testsuite/tests/tool-toplevel/*.a +/testsuite/tests/tool-toplevel/*.so +/testsuite/tests/tool-toplevel/*.obj +/testsuite/tests/tool-toplevel/*.lib +/testsuite/tests/tool-toplevel/*.dll +/testsuite/tests/tool-toplevel/*.cm[ioxat] +/testsuite/tests/tool-toplevel/*.cmx[as] +/testsuite/tests/tool-toplevel/*.cmti +/testsuite/tests/tool-toplevel/*.annot +/testsuite/tests/tool-toplevel/*.result +/testsuite/tests/tool-toplevel/*.byte +/testsuite/tests/tool-toplevel/*.native +/testsuite/tests/tool-toplevel/program +/testsuite/tests/tool-toplevel/*.exe +/testsuite/tests/tool-toplevel/*.exe.manifest +/testsuite/tests/tool-toplevel/.depend +/testsuite/tests/tool-toplevel/.depend.nt +/testsuite/tests/tool-toplevel/.DS_Store + +# /testsuite/tests/typing-extensions/ +/testsuite/tests/typing-extensions/*.o +/testsuite/tests/typing-extensions/*.a +/testsuite/tests/typing-extensions/*.so +/testsuite/tests/typing-extensions/*.obj +/testsuite/tests/typing-extensions/*.lib +/testsuite/tests/typing-extensions/*.dll +/testsuite/tests/typing-extensions/*.cm[ioxat] +/testsuite/tests/typing-extensions/*.cmx[as] +/testsuite/tests/typing-extensions/*.cmti +/testsuite/tests/typing-extensions/*.annot +/testsuite/tests/typing-extensions/*.result +/testsuite/tests/typing-extensions/*.byte +/testsuite/tests/typing-extensions/*.native +/testsuite/tests/typing-extensions/program +/testsuite/tests/typing-extensions/*.exe +/testsuite/tests/typing-extensions/*.exe.manifest +/testsuite/tests/typing-extensions/.depend +/testsuite/tests/typing-extensions/.depend.nt +/testsuite/tests/typing-extensions/.DS_Store + # /testsuite/tests/typing-fstclassmod/ /testsuite/tests/typing-fstclassmod/*.o /testsuite/tests/typing-fstclassmod/*.a @@ -1,6 +1,17 @@ -Next version: +OCaml 4.03.0: ------------- +Compilers: +- PR#6501: harden the native-code generator against certain uses of "%identity" + (Xavier Leroy, report by Antoine Miné). + +Runtime system: +- PR#6517: use ISO C99 types {,u}int{32,64}_t in preference to our homegrown + types {,u}int{32,64}. + (Xavier Leroy) +- PR#6529: fix quadratic-time algorithm in Consistbl.extract. + (Xavier Leroy) + Ocaml 4.02.0: ------------- @@ -9,7 +20,7 @@ Ocaml 4.02.0: Language features: - Attributes and extension nodes (Alain Frisch) -- PR#5095: Generative functors +- Generative functors (PR#5905) (Jacques Garrigue) - Module aliases (Jacques Garrigue) @@ -26,6 +37,7 @@ Language features: Build system for the OCaml distribution: - Use -bin-annot when building. - Use GNU make instead of portable makefiles. +- Updated build instructions for 32-bit Mac OS X on Intel hardware. Shedding weight: * Removed Camlp4 from the distribution, now available as third-party software. @@ -43,7 +55,7 @@ Type system: * Module aliases are now typed in a specific way, which remembers their identity. In particular this changes the signature inferred by "module type of" - (Jacques Garrigue) + (Jacques Garrigue, feedback from Leo White, Mark Shinwell and Nick Chapman) - PR#6331: Slight change in the criterion to distinguish private abbreviations and private row types: create a private abbreviation for closed objects and fixed polymorphic variants. @@ -72,29 +84,28 @@ Compilers: - PR#6042: Optimization of integer division and modulus by constant divisors (Xavier Leroy and Phil Denys) - Add "-open" command line flag for opening a single module before typing + (Leo White, Mark Shinwell and Nick Chapman) * "-o" now sets module name to the output file name up to the first "." (it also applies when "-o" is not given, i.e. the module name is then the input file name up to the first ".") - (Leo White and Mark Shinwell) + (Leo White, Mark Shinwell and Nick Chapman) * PR#5779: better sharing of structured constants (Alain Frisch) -- PR#6182: better message for virtual objects and class types - (Leo P. White, Stephen Dolan) - PR#5817: new flag to keep locations in cmi files (Alain Frisch) - PR#5854: issue warning 3 when referring to a value marked with the [@@ocaml.deprecated] attribute (Alain Frisch, suggestion by Pierre-Marie Pédrot) +- PR#6017: a new format implementation based on GADTs + (Benoît Vaugon and Gabriel Scherer) * PR#6203: Constant exception constructors no longer allocate (Alain Frisch) -- PR#6311: Improve signature mismatch error messages - (Alain Frisch, suggestion by Daniel Bünzli) +- PR#6260: avoid unnecessary boxing in let + (Vladimir Brankov) - PR#6345: Better compilation of optional arguments with default values (Alain Frisch, review by Jacques Garrigue) -- PR#6260: Unnecessary boxing in let - (Vladimir Brankov) -- PR#6017: a new format implementation based on GADTs - (Benoît Vaugon and Gabriel Scherer) +- PR#6389: ocamlopt -opaque option for incremental native compilation + (Pierre Chambart, Gabriel Scherer) Toplevel interactive system: - PR#5377: New "#show_*" directives @@ -116,7 +127,7 @@ Runtime system: - Fixed a major performance problem on large heaps (~1GB) by making heap increments proportional to heap size by default (Damien Doligez) -- PR#4765: Structural equality should treat exception specifically +- PR#4765: Structural equality treats exception specifically (Alain Frisch) - PR#5009: efficient comparison/indexing of exceptions (Alain Frisch, request by Markus Mottl) @@ -129,7 +140,7 @@ Runtime system: (Xavier Leroy) Standard library: -* Add new modules: Bytes and BytesLabels. +* Add new modules Bytes and BytesLabels for mutable byte sequences. (Damien Doligez) - PR#4986: add List.sort_uniq and Set.of_list (Alain Frisch) @@ -141,11 +152,17 @@ Standard library: (John Whitington) - PR#6180: efficient creation of uninitialized float arrays (Alain Frisch, request by Markus Mottl) +- PR#6355: Improve documentation regarding finalisers and multithreading + (Daniel Bünzli, Mark Shinwell) +- Trigger warning 3 for all values marked as deprecated in the documentation. + (Damien Doligez) OCamldoc: - PR#6257: handle full doc comments for variant constructors and record fields (Maxence Guesdon, request by ygrek) +- PR#6274: allow doc comments on object types + (Thomas Refis) - PR#6310: fix ocamldoc's subscript/superscript CSS font size (Anil Madhavapeddy) - PR#6425: fix generation of man pages @@ -156,35 +173,26 @@ Bug fixes: try...with Invalid_argument -> _ ... (Xavier Leroy) - PR#4719: Sys.executable_name wrong if executable name contains dots (Windows) (Alain Frisch, report by Bart Jacobs) -- PR#4855: 'camlp4 -I +dir' accepted, dir is relative to 'camlp4 -where' - (Jun Furuse and Hongbo Zhang, report by Dmitry Grebeniuk) -- PR#5201: ocamlbuild: add --norc to the bash invocation to help performances - (user 'daweil') -- PR#5598: follow-up fix related to PR#6165 - (Damien Doligez) +- PR#5406 ocamlbuild: "tag 'package' does not expect a parameter" + (Gabriel Scherer) +- PR#5598, PR#6165: Alterations to handling of \013 in source files + breaking other tools + (David Allsopp and Damien Doligez) - PR#5820: Fix camlp4 lexer roll back problem (Hongbo Zhang) +- PR#5946: CAMLprim taking (void) as argument + (Benoît Vaugon) - PR#6038: on x86-32, enforce 16-byte stack alignment for compatibility with recent GCC and Clang. Win32/MSVC keeps 4-byte stack alignment. (Xavier Leroy) -- PR#6062: Fix a regression bug caused by commit 13047 +- PR#6062: Fix a 4.01 camlp4 DELETE_RULE regression caused by commit 13047 (Hongbo Zhang, report by Christophe Troestler) -- PR#6109: Typos in ocamlbuild error messages - (Gabriel Kerneis) -- PR#6116: more efficient implementation of Digest.to_hex - (ygrek) -- PR#6142: add cmt file support to ocamlobjinfo - (Anil Madhavapeddy) -- PR#6165: Alterations to handling of \013 in source files breaking other tools - (David Allsopp) - PR#6173: Typing error message is worse than before (Jacques Garrigue and John Whitington) - PR#6174: OCaml compiler loops on an example using GADTs (-rectypes case) (Jacques Garrigue and Grégoire Henry, report by Chantal Keller) -- PR#6175: add open! support to camlp4 +- PR#6175: open! was not suppored by camlp4 (Hongbo Zhang) -- PR#6183: enhanced documentation for 'Unix.shutdown_connection' - (Anil Madhavapeddy, report by Jun Furuse) - PR#6184: ocamlbuild: `ocamlfind ocamldep` does not support -predicate (Jacques-Pascal Deplaix) - PR#6194: Incorrect unused warning with first-class modules in patterns @@ -194,6 +202,8 @@ Bug fixes: (Xavier Leroy) - PR#6216: inlining of GADT matches generates invalid assembly (Xavier Leroy and Alain Frisch, report by Mark Shinwell) +- PR#6232: Don't use [mktemp] on platforms where [mkstemp] is available + (Stéphane Glondu, Mark Shinwell) - PR#6233: out-of-bounds exceptions lose their locations on ARM, PowerPC (Jacques-Henri Jourdan and Xavier Leroy, report and testing by Stéphane Glondu) @@ -210,8 +220,6 @@ Bug fixes: (Xavier Leroy, report by Pierre-Marie Pédrot) - PR#6262: equality of first-class modules take module aliases into account (Alain Frisch and Leo White) -- PR#6267: more information printed by "bt" command of ocamldebug - (Josh Watzman) - PR#6268: -DMODEL_$(MODEL) not passed when building asmrun/arm.p.o (Peter Michael Green) - PR#6273: fix Sys.file_exists on large files (Win32) @@ -220,10 +228,14 @@ Bug fixes: (Jacques Garrigue, report by Leo White) - PR#6293: Assert_failure with invalid package type (Jacques Garrigue, report by Elnatan Reisner) +- PR#6300: ocamlbuild -use-ocamlfind conflicts with -ocamlc + (Gabriel Scherer) - PR#6302: bytecode debug information re-read from filesystem every time (Jacques-Henri Jourdan) - PR#6307: Behavior of 'module type of' w.r.t. module aliases (Jacques Garrigue, report by Alain Frisch) +- PR#6332: Unix.open_process fails to pass empty arguments under Windows + (Damien Doligez, report Virgile Prevosto) - PR#6346: Build failure with latest version of xcode on OSX (Jérémie Dimino) - PR#6348: Unification failure for GADT when original definition is hidden @@ -242,17 +254,41 @@ Bug fixes: (Alain Frisch and Jacques Garrigue) - PR#6405: unsound interaction of -rectypes and GADTs (Jacques Garrigue, report by Gabriel Scherer and Benoît Vaugon) -- PR#6418: reimplement parametrized Format tags/indentation with GADTs - (Benoît Vaugon) +- PR#6408: Optional arguments given as ~?arg instead of ?arg in message + (Michael O'Connor) +- PR#6411: missing libgcc_s_sjlj-1.dll in mingw (add -static-libgcc) + (Jun Furuse and Alain Frisch, Jonathan Protzenko and Adrien Nader) +- PR#6436: Typos in @deprecated text in stdlib/arrayLabels.mli + (John Whitington) +- PR#6439: Don't use the deprecated [getpagesize] function + (John Whitington, Mark Shinwell) +- PR#6441: undetected tail-call in some mutually-recursive functions + (many arguments, and mutual block mixes functions and non-functions) + (Stefan Holdermans, review by Xavier Leroy) +- PR#6443: ocaml segfault when List.fold_left is traced then executed + (Jacques Garrigue, report by user 'Reventlov') +- PR#6451: some bugs in untypeast.ml + (Jun Furuse, review by Alain Frisch) - PR#6460: runtime assertion failure with large [| e1;...eN |] float array expressions (Leo White) +- PR#6463: -dtypedtree fails on class fields + (Leo White) +- PR#6469: invalid -dsource printing of "external _pipe = ...", "Pervasives.(!)" + (Gabriel Scherer and Damien Doligez, user 'ngunn') - PR#6482: ocamlbuild fails when _tags file in unhygienic directory (Gabriel Scherer) +- PR#6502: ocamlbuild spurious warning on "use_menhir" tag + (Xavier Leroy) +- PR#6505: Missed Type-error leads to a segfault upon record access + (Jacques Garrigue, Jeremy Yallop, report by Christoph Höger) +- PR#6507: crash on AArch64 resulting from incorrect setting of + [caml_bottom_of_stack]. (Richard Jones, Mark Shinwell) - PR#6509: add -linkall flag to ocamlcommon.cma (Frédéric Bour) -- fix -dsource printing of "external _pipe = ..." - (Gabriel Scherer) +- PR#6513: Fatal error Ctype.Unify(_) in functor type +- PR#6523: failure upon character bigarray access, and unnecessary change + in comparison ordering (Jeremy Yallop, Mark Shinwell) - bound-checking bug in caml_string_{get,set}{16,32,64} (Pierre Chambart and Gabriel Scherer, report by Nicolas Trangez) - sometimes wrong stack alignment at out-of-bounds array access @@ -264,10 +300,18 @@ Features wishes: - PR#4323: have "of_string" in Num and Big_int work with binary and hex representations (Zoe Paraskevopoulou, review by Gabriel Scherer) +- PR#4771: Clarify documentation of Dynlink.allow_only + (Damien Doligez, report by David Allsopp) +- PR#4855: 'camlp4 -I +dir' accepted, dir is relative to 'camlp4 -where' + (Jun Furuse and Hongbo Zhang, report by Dmitry Grebeniuk) +- PR#5201: ocamlbuild: add --norc to the bash invocation to help performances + (user 'daweil') - PR#5650: Camlp4FoldGenerator doesn't handle well "abstract" types (Hongbo Zhang) - PR#5808: allow simple patterns, not just identifiers, in "let p : t = ..." (Alain Frisch) +- PR#5851: warn when -r is disabled because no _tags file is present + (Gabriel Scherer) - PR#5899: a programmer-friendly access to backtrace information (Jacques-Henri Jourdan and Gabriel Scherer) - PR#6000 comment 9644: add a warning for non-principal coercions to format @@ -278,23 +322,48 @@ Features wishes: (Jeremy Yallop, review by Gabriel Scherer) - PR#6071: Add a -noinit option to the toplevel (David Sheets) +- PR#6087: ocamlbuild, improve _tags parsing of escaped newlines + (Gabriel Scherer, request by Daniel Bünzli) +- PR#6109: Typos in ocamlbuild error messages + (Gabriel Kerneis) +- PR#6116: more efficient implementation of Digest.to_hex + (ygrek) +- PR#6142: add cmt file support to ocamlobjinfo + (Anil Madhavapeddy) - PR#6166: document -ocamldoc option of ocamlbuild (Xavier Clerc) +- PR#6182: better message for virtual objects and class types + (Leo White, Stephen Dolan) +- PR#6183: enhanced documentation for 'Unix.shutdown_connection' + (Anil Madhavapeddy, report by Jun Furuse) - PR#6187: ocamlbuild: warn when using -plugin-tag(s) without myocamlbuild.ml (Jacques-Pascal Deplaix) -- PR#6246: allow wilcard _ as for-loop index +- PR#6246: allow wildcard _ as for-loop index (Alain Frisch, request by ygrek) +- PR#6267: more information printed by "bt" command of ocamldebug + (Josh Watzman) - PR#6270: remove need for -I directives to ocamldebug in common case (Josh Watzman, review by Xavier Clerc and Alain Frisch) +- PR#6311: Improve signature mismatch error messages + (Alain Frisch, suggestion by Daniel Bünzli) - PR#6358: obey DESTDIR in install targets (Gabriel Scherer, request by François Berenger) +- PR#6388, PR#6424: more parsetree correctness checks for -ppx users + (Alain Frisch, request by Peter Zotov and Jun Furuse) - PR#6406: Expose OCaml version in C headers (Peter Zotov and Romain Calascibetta) +- PR#6446: improve "unused declaration" warnings wrt. name shadowing + (Alain Frisch) +- PR#6495: ocamlbuild tags 'safe_string', 'unsafe_string' + (Anil Madhavapeddy) +- PR#6497: pass context information to -ppx preprocessors + (Peter Zotov, Alain Frisch) - ocamllex: user-definable refill action (Frédéric Bour, review by Gabriel Scherer and Luc Maranget) - shorten syntax for functor signatures: "functor (M1:S1) (M2:S2) .. -> .." (Thomas Gazagnaire and Jeremy Yallop, review by Gabriel Scherer) - +- make ocamldebug -I auto-detection work with ocamlbuild + (Josh Watzman) OCaml 4.01.0: ------------- @@ -715,8 +784,6 @@ Feature wishes: (Anil Madhavapeddy) - PR#6060: ocamlbuild tags 'principal', 'strict_sequence' and 'short_paths' (Anil Madhavapeddy) -- PR#6495: ocamlbuild tags 'safe_string', 'unsafe_string' - (Anil Madhavapeddy) - ocamlbuild tag 'no_alias_deps' (Daniel Bünzli) diff --git a/README.win32 b/README.win32 index 7575888f1a..111c9a107c 100644 --- a/README.win32 +++ b/README.win32 @@ -260,6 +260,12 @@ NOTES: * The replay debugger is partially supported (no reverse execution). +* The default Makefile.mingw passes -static-libgcc to the linker. + For more information on this topic: + + http://gcc.gnu.org/onlinedocs/gcc-4.9.1/gcc/Link-Options.html#Link-Options + http://caml.inria.fr/mantis/view.php?id=6411 + ------------------------------------------------------------------------------ The Cygwin port of OCaml @@ -1,4 +1,4 @@ -4.03.0+dev1-2014-07-21 +4.03.0+dev3-2014-08-29 # The version string is the first line of this file. # It must be in the format described in stdlib/sys.mli diff --git a/asmcomp/CSEgen.mli b/asmcomp/CSEgen.mli index ffea33891c..0b375ff571 100644 --- a/asmcomp/CSEgen.mli +++ b/asmcomp/CSEgen.mli @@ -33,6 +33,3 @@ class cse_generic : object method fundecl: Mach.fundecl -> Mach.fundecl end - - - diff --git a/asmcomp/amd64/CSE.ml b/asmcomp/amd64/CSE.ml index 6c9b76e822..aee43d2bca 100644 --- a/asmcomp/amd64/CSE.ml +++ b/asmcomp/amd64/CSE.ml @@ -36,4 +36,3 @@ end let fundecl f = (new cse)#fundecl f - diff --git a/asmcomp/amd64/arch.ml b/asmcomp/amd64/arch.ml index 3741dd74bc..a4f1abd974 100644 --- a/asmcomp/amd64/arch.ml +++ b/asmcomp/amd64/arch.ml @@ -33,7 +33,8 @@ type addressing_mode = type specific_operation = Ilea of addressing_mode (* "lea" gives scaled adds *) - | Istore_int of nativeint * addressing_mode * bool (* Store an integer constant *) + | Istore_int of nativeint * addressing_mode * bool + (* Store an integer constant *) | Istore_symbol of string * addressing_mode * bool (* Store a symbol *) | Ioffset_loc of int * addressing_mode (* Add a constant to a location *) | Ifloatarithmem of float_operation * addressing_mode diff --git a/asmcomp/amd64/proc.ml b/asmcomp/amd64/proc.ml index e3f0d2950a..298e92900d 100644 --- a/asmcomp/amd64/proc.ml +++ b/asmcomp/amd64/proc.ml @@ -117,12 +117,12 @@ let rotate_registers = false (* Representation of hard registers by pseudo-registers *) let hard_int_reg = - let v = Array.create 13 Reg.dummy in + let v = Array.make 13 Reg.dummy in for i = 0 to 12 do v.(i) <- Reg.at_location Int (Reg i) done; v let hard_float_reg = - let v = Array.create 16 Reg.dummy in + let v = Array.make 16 Reg.dummy in for i = 0 to 15 do v.(i) <- Reg.at_location Float (Reg (100 + i)) done; v @@ -149,7 +149,7 @@ let word_addressed = false let calling_conventions first_int last_int first_float last_float make_stack arg = - let loc = Array.create (Array.length arg) Reg.dummy in + let loc = Array.make (Array.length arg) Reg.dummy in let int = ref first_int in let float = ref first_float in let ofs = ref 0 in @@ -210,7 +210,7 @@ let win64_float_external_arguments = [| 100 (*xmm0*); 101 (*xmm1*); 102 (*xmm2*); 103 (*xmm3*) |] let win64_loc_external_arguments arg = - let loc = Array.create (Array.length arg) Reg.dummy in + let loc = Array.make (Array.length arg) Reg.dummy in let reg = ref 0 and ofs = ref 32 in for i = 0 to Array.length arg - 1 do diff --git a/asmcomp/arm/CSE.ml b/asmcomp/arm/CSE.ml index 00282f1f55..bea333dc42 100644 --- a/asmcomp/arm/CSE.ml +++ b/asmcomp/arm/CSE.ml @@ -35,4 +35,3 @@ end let fundecl f = (new cse)#fundecl f - diff --git a/asmcomp/arm/arch.ml b/asmcomp/arm/arch.ml index fbd9f6db02..d93c1e0e46 100644 --- a/asmcomp/arm/arch.ml +++ b/asmcomp/arm/arch.ml @@ -21,7 +21,7 @@ type fpu = Soft | VFPv2 | VFPv3_D16 | VFPv3 let abi = match Config.system with - "linux_eabi" -> EABI + "linux_eabi" | "freebsd" -> EABI | "linux_eabihf" -> EABI_HF | _ -> assert false diff --git a/asmcomp/arm/proc.ml b/asmcomp/arm/proc.ml index 99c59dd9cb..6b2ba3cf3a 100644 --- a/asmcomp/arm/proc.ml +++ b/asmcomp/arm/proc.ml @@ -82,14 +82,14 @@ let rotate_registers = true (* Representation of hard registers by pseudo-registers *) let hard_int_reg = - let v = Array.create 9 Reg.dummy in + let v = Array.make 9 Reg.dummy in for i = 0 to 8 do v.(i) <- Reg.at_location Int (Reg i) done; v let hard_float_reg = - let v = Array.create 32 Reg.dummy in + let v = Array.make 32 Reg.dummy in for i = 0 to 31 do v.(i) <- Reg.at_location Float (Reg(100 + i)) done; @@ -108,7 +108,7 @@ let stack_slot slot ty = let calling_conventions first_int last_int first_float last_float make_stack arg = - let loc = Array.create (Array.length arg) Reg.dummy in + let loc = Array.make (Array.length arg) Reg.dummy in let int = ref first_int in let float = ref first_float in let ofs = ref 0 in diff --git a/asmcomp/arm64/CSE.ml b/asmcomp/arm64/CSE.ml index 359e57eb55..f9e03e487e 100644 --- a/asmcomp/arm64/CSE.ml +++ b/asmcomp/arm64/CSE.ml @@ -35,4 +35,3 @@ end let fundecl f = (new cse)#fundecl f - diff --git a/asmcomp/arm64/proc.ml b/asmcomp/arm64/proc.ml index 9e19d477f5..0222b72a73 100644 --- a/asmcomp/arm64/proc.ml +++ b/asmcomp/arm64/proc.ml @@ -76,14 +76,14 @@ let rotate_registers = true (* Representation of hard registers by pseudo-registers *) let hard_int_reg = - let v = Array.create 28 Reg.dummy in + let v = Array.make 28 Reg.dummy in for i = 0 to 27 do v.(i) <- Reg.at_location Int (Reg i) done; v let hard_float_reg = - let v = Array.create 32 Reg.dummy in + let v = Array.make 32 Reg.dummy in for i = 0 to 31 do v.(i) <- Reg.at_location Float (Reg(100 + i)) done; @@ -105,7 +105,7 @@ let stack_slot slot ty = let calling_conventions first_int last_int first_float last_float make_stack arg = - let loc = Array.create (Array.length arg) Reg.dummy in + let loc = Array.make (Array.length arg) Reg.dummy in let int = ref first_int in let float = ref first_float in let ofs = ref 0 in diff --git a/asmcomp/asmlink.ml b/asmcomp/asmlink.ml index f0ca7ba296..153da7cace 100644 --- a/asmcomp/asmlink.ml +++ b/asmcomp/asmlink.ml @@ -412,6 +412,3 @@ let reset () = cmx_required := []; interfaces := []; implementations := [] - - - diff --git a/asmcomp/closure.ml b/asmcomp/closure.ml index 9d3749d44d..249e67c4e5 100644 --- a/asmcomp/closure.ml +++ b/asmcomp/closure.ml @@ -1177,7 +1177,7 @@ and close_one_function fenv cenv id funct = and close_switch arg fenv cenv cases num_keys default = let ncases = List.length cases in - let index = Array.create num_keys 0 + let index = Array.make num_keys 0 and store = Storer.mk_store () in (* First default case *) @@ -1291,6 +1291,8 @@ let intro size lam = global_approx := Array.init size (fun i -> Value_global_field (id, i)); Compilenv.set_global_approx(Value_tuple !global_approx); let (ulam, approx) = close Tbl.empty Tbl.empty lam in - collect_exported_structured_constants (Value_tuple !global_approx); + if !Clflags.opaque + then Compilenv.set_global_approx(Value_unknown) + else collect_exported_structured_constants (Value_tuple !global_approx); global_approx := [||]; ulam diff --git a/asmcomp/cmmgen.ml b/asmcomp/cmmgen.ml index b68b6a616a..24c2d41abd 100644 --- a/asmcomp/cmmgen.ml +++ b/asmcomp/cmmgen.ml @@ -38,7 +38,8 @@ let bind_nonvar name arg fn = | Cconst_blockheader _ -> fn arg | _ -> let id = Ident.create name in Clet(id, arg, fn (Cvar id)) -let caml_black = Nativeint.shift_left (Nativeint.of_int 3) 8 (* cf. byterun/gc.h *) +let caml_black = Nativeint.shift_left (Nativeint.of_int 3) 8 + (* cf. byterun/gc.h *) (* Block headers. Meaning of the tag field: see stdlib/obj.ml *) @@ -2411,7 +2412,7 @@ let cache_public_method meths tag cache = *) let apply_function_body arity = - let arg = Array.create arity (Ident.create "arg") in + let arg = Array.make arity (Ident.create "arg") in for i = 1 to arity - 1 do arg.(i) <- Ident.create "arg" done; let clos = Ident.create "clos" in let rec app_fun clos n = diff --git a/asmcomp/coloring.ml b/asmcomp/coloring.ml index 67ed8729e5..aff4ad626c 100644 --- a/asmcomp/coloring.ml +++ b/asmcomp/coloring.ml @@ -47,7 +47,7 @@ let allocate_registers() = if reg.spill then begin (* Preallocate the registers in the stack *) let nslots = Proc.num_stack_slots.(cl) in - let conflict = Array.create nslots false in + let conflict = Array.make nslots false in List.iter (fun r -> match r.loc with @@ -84,14 +84,14 @@ let allocate_registers() = (* Where to start the search for a suitable register. Used to introduce some "randomness" in the choice between registers with equal scores. This offers more opportunities for scheduling. *) - let start_register = Array.create Proc.num_register_classes 0 in + let start_register = Array.make Proc.num_register_classes 0 in (* Assign a location to a register, the best we can. *) let assign_location reg = let cl = Proc.register_class reg in let first_reg = Proc.first_available_register.(cl) in let num_regs = Proc.num_available_registers.(cl) in - let score = Array.create num_regs 0 in + let score = Array.make num_regs 0 in let best_score = ref (-1000000) and best_reg = ref (-1) in let start = start_register.(cl) in if num_regs <> 0 then begin @@ -161,7 +161,7 @@ let allocate_registers() = end else begin (* Sorry, we must put the pseudoreg in a stack location *) let nslots = Proc.num_stack_slots.(cl) in - let score = Array.create nslots 0 in + let score = Array.make nslots 0 in (* Compute the scores as for registers *) List.iter (fun (r, w) -> diff --git a/asmcomp/i386/CSE.ml b/asmcomp/i386/CSE.ml index 3ce4567024..6bea76f1a1 100644 --- a/asmcomp/i386/CSE.ml +++ b/asmcomp/i386/CSE.ml @@ -45,4 +45,3 @@ end let fundecl f = (new cse)#fundecl f - diff --git a/asmcomp/i386/arch.ml b/asmcomp/i386/arch.ml index 25e6edb68d..1d486db3ec 100644 --- a/asmcomp/i386/arch.ml +++ b/asmcomp/i386/arch.ml @@ -31,11 +31,12 @@ type addressing_mode = type specific_operation = Ilea of addressing_mode (* Lea gives scaled adds *) - | Istore_int of nativeint * addressing_mode * bool (* Store an integer constant *) + | Istore_int of nativeint * addressing_mode * bool + (* Store an integer constant *) | Istore_symbol of string * addressing_mode * bool (* Store a symbol *) | Ioffset_loc of int * addressing_mode (* Add a constant to a location *) | Ipush (* Push regs on stack *) - | Ipush_int of nativeint (* Push an integer constant *) + | Ipush_int of nativeint (* Push an integer constant *) | Ipush_symbol of string (* Push a symbol *) | Ipush_load of addressing_mode (* Load a scalar and push *) | Ipush_load_float of addressing_mode (* Load a float and push *) diff --git a/asmcomp/i386/proc.ml b/asmcomp/i386/proc.ml index 8bbd42c158..0b010d248f 100644 --- a/asmcomp/i386/proc.ml +++ b/asmcomp/i386/proc.ml @@ -72,7 +72,7 @@ let rotate_registers = false (* Representation of hard registers by pseudo-registers *) let hard_int_reg = - let v = Array.create 7 Reg.dummy in + let v = Array.make 7 Reg.dummy in for i = 0 to 6 do v.(i) <- Reg.at_location Int (Reg i) done; v @@ -111,7 +111,7 @@ let word_addressed = false let calling_conventions first_int last_int first_float last_float make_stack arg = - let loc = Array.create (Array.length arg) Reg.dummy in + let loc = Array.make (Array.length arg) Reg.dummy in let int = ref first_int in let float = ref first_float in let ofs = ref (-64) in diff --git a/asmcomp/linearize.ml b/asmcomp/linearize.ml index 48dde690c4..64678c1d4d 100644 --- a/asmcomp/linearize.ml +++ b/asmcomp/linearize.ml @@ -224,7 +224,7 @@ let rec linear i n = (linear ifso (add_branch lbl_end nelse)) end | Iswitch(index, cases) -> - let lbl_cases = Array.create (Array.length cases) 0 in + let lbl_cases = Array.make (Array.length cases) 0 in let (lbl_end, n1) = get_label(linear i.Mach.next n) in let n2 = ref (discard_dead_code n1) in for i = Array.length cases - 1 downto 0 do diff --git a/asmcomp/power/CSE.ml b/asmcomp/power/CSE.ml index 50fefa5e35..ec10d2df4c 100644 --- a/asmcomp/power/CSE.ml +++ b/asmcomp/power/CSE.ml @@ -35,4 +35,3 @@ end let fundecl f = (new cse)#fundecl f - diff --git a/asmcomp/power/proc.ml b/asmcomp/power/proc.ml index bafa8a4c5f..934d2cbfeb 100644 --- a/asmcomp/power/proc.ml +++ b/asmcomp/power/proc.ml @@ -83,11 +83,11 @@ let rotate_registers = true (* Representation of hard registers by pseudo-registers *) let hard_int_reg = - let v = Array.create 23 Reg.dummy in + let v = Array.make 23 Reg.dummy in for i = 0 to 22 do v.(i) <- Reg.at_location Int (Reg i) done; v let hard_float_reg = - let v = Array.create 31 Reg.dummy in + let v = Array.make 31 Reg.dummy in for i = 0 to 30 do v.(i) <- Reg.at_location Float (Reg(100 + i)) done; v let all_phys_regs = @@ -103,7 +103,7 @@ let stack_slot slot ty = let calling_conventions first_int last_int first_float last_float make_stack stack_ofs arg = - let loc = Array.create (Array.length arg) Reg.dummy in + let loc = Array.make (Array.length arg) Reg.dummy in let int = ref first_int in let float = ref first_float in let ofs = ref stack_ofs in @@ -157,7 +157,7 @@ let loc_results res = let poweropen_external_conventions first_int last_int first_float last_float arg = - let loc = Array.create (Array.length arg) Reg.dummy in + let loc = Array.make (Array.length arg) Reg.dummy in let int = ref first_int in let float = ref first_float in let ofs = ref (14 * size_addr) in diff --git a/asmcomp/reg.ml b/asmcomp/reg.ml index ef6db5cb6e..064be4dbb7 100644 --- a/asmcomp/reg.ml +++ b/asmcomp/reg.ml @@ -32,7 +32,7 @@ end type t = { mutable raw_name: Raw_name.t; stamp: int; - typ: Cmm.machtype_component; + mutable typ: Cmm.machtype_component; mutable loc: location; mutable spill: bool; mutable part: int option; @@ -73,13 +73,13 @@ let create ty = let createv tyv = let n = Array.length tyv in - let rv = Array.create n dummy in + let rv = Array.make n dummy in for i = 0 to n-1 do rv.(i) <- create tyv.(i) done; rv let createv_like rv = let n = Array.length rv in - let rv' = Array.create n dummy in + let rv' = Array.make n dummy in for i = 0 to n-1 do rv'.(i) <- create rv.(i).typ done; rv' diff --git a/asmcomp/reg.mli b/asmcomp/reg.mli index e3cb2d9520..f705c209ee 100644 --- a/asmcomp/reg.mli +++ b/asmcomp/reg.mli @@ -20,7 +20,7 @@ end type t = { mutable raw_name: Raw_name.t; (* Name *) stamp: int; (* Unique stamp *) - typ: Cmm.machtype_component; (* Type of contents *) + mutable typ: Cmm.machtype_component;(* Type of contents *) mutable loc: location; (* Actual location *) mutable spill: bool; (* "true" to force stack allocation *) mutable part: int option; (* Zero-based index of part of value *) diff --git a/asmcomp/reloadgen.ml b/asmcomp/reloadgen.ml index a9c74bb1d3..30f23a8254 100644 --- a/asmcomp/reloadgen.ml +++ b/asmcomp/reloadgen.ml @@ -54,7 +54,7 @@ method makereg r = method private makeregs rv = let n = Array.length rv in - let newv = Array.create n Reg.dummy in + let newv = Array.make n Reg.dummy in for i = 0 to n-1 do newv.(i) <- self#makereg rv.(i) done; newv diff --git a/asmcomp/selectgen.ml b/asmcomp/selectgen.ml index 50a38a244e..86e16d38f4 100644 --- a/asmcomp/selectgen.ml +++ b/asmcomp/selectgen.ml @@ -111,7 +111,7 @@ let join opt_r1 seq1 opt_r2 seq2 = | (Some r1, Some r2) -> let l1 = Array.length r1 in assert (l1 = Array.length r2); - let r = Array.create l1 Reg.dummy in + let r = Array.make l1 Reg.dummy in for i = 0 to l1-1 do if Reg.anonymous r1.(i) then begin r.(i) <- r1.(i); @@ -139,7 +139,7 @@ let join_array rs = None -> None | Some template -> let size_res = Array.length template in - let res = Array.create size_res Reg.dummy in + let res = Array.make size_res Reg.dummy in for i = 0 to size_res - 1 do res.(i) <- Reg.create template.(i).typ done; @@ -393,6 +393,24 @@ method insert_moves src dst = self#insert_move src.(i) dst.(i) done +(* Adjust the types of destination pseudoregs for a [Cassign] assignment. + The type inferred at [let] binding might be [Int] while we assign + something of type [Addr] (PR#6501). *) + +method adjust_type src dst = + let ts = src.typ and td = dst.typ in + if ts <> td then + match ts, td with + | Addr, Int -> dst.typ <- Addr + | Int, Addr -> () + | _, _ -> fatal_error("Selection.adjust_type: bad assignment to " + ^ Reg.name dst) + +method adjust_types src dst = + for i = 0 to min (Array.length src) (Array.length dst) - 1 do + self#adjust_type src.(i) dst.(i) + done + (* Insert moves and stack offsets for function arguments and results *) method insert_move_args arg loc stacksize = @@ -459,7 +477,7 @@ method emit_expr env exp = fatal_error ("Selection.emit_expr: unbound var " ^ Ident.name v) in begin match self#emit_expr env e1 with None -> None - | Some r1 -> self#insert_moves r1 rv; Some [||] + | Some r1 -> self#adjust_types r1 rv; self#insert_moves r1 rv; Some [||] end | Ctuple [] -> Some [||] diff --git a/asmcomp/selectgen.mli b/asmcomp/selectgen.mli index 0de9038215..499b9ea0fe 100644 --- a/asmcomp/selectgen.mli +++ b/asmcomp/selectgen.mli @@ -97,6 +97,8 @@ class virtual selector_generic : object method insert_move_args : Reg.t array -> Reg.t array -> int -> unit method insert_move_results : Reg.t array -> Reg.t array -> int -> unit method insert_moves : Reg.t array -> Reg.t array -> unit + method adjust_type : Reg.t -> Reg.t -> unit + method adjust_types : Reg.t array -> Reg.t array -> unit method emit_expr : (Ident.t, Reg.t array) Tbl.t -> Cmm.expression -> Reg.t array option method emit_tail : (Ident.t, Reg.t array) Tbl.t -> Cmm.expression -> unit diff --git a/asmcomp/sparc/CSE.ml b/asmcomp/sparc/CSE.ml index c38bab8fe1..e48d604365 100644 --- a/asmcomp/sparc/CSE.ml +++ b/asmcomp/sparc/CSE.ml @@ -28,4 +28,3 @@ end let fundecl f = (new cse)#fundecl f - diff --git a/asmcomp/sparc/proc.ml b/asmcomp/sparc/proc.ml index ff353d6283..625f517f61 100644 --- a/asmcomp/sparc/proc.ml +++ b/asmcomp/sparc/proc.ml @@ -81,12 +81,12 @@ let rotate_registers = true (* Representation of hard registers by pseudo-registers *) let hard_int_reg = - let v = Array.create 19 Reg.dummy in + let v = Array.make 19 Reg.dummy in for i = 0 to 18 do v.(i) <- Reg.at_location Int (Reg i) done; v let hard_float_reg = - let v = Array.create 32 Reg.dummy in + let v = Array.make 32 Reg.dummy in for i = 0 to 31 do v.(i) <- Reg.at_location Float (Reg(100 + i)) done; v @@ -105,7 +105,7 @@ let stack_slot slot ty = let calling_conventions first_int last_int first_float last_float make_stack arg = - let loc = Array.create (Array.length arg) Reg.dummy in + let loc = Array.make (Array.length arg) Reg.dummy in let int = ref first_int in let float = ref first_float in let ofs = ref 0 in diff --git a/asmcomp/spill.ml b/asmcomp/spill.ml index 36d1e6812d..105550d056 100644 --- a/asmcomp/spill.ml +++ b/asmcomp/spill.ml @@ -64,7 +64,7 @@ let add_superpressure_regs op live_regs res_regs spilled = let max_pressure = Proc.max_register_pressure op in let regs = Reg.add_set_array live_regs res_regs in (* Compute the pressure in each register class *) - let pressure = Array.create Proc.num_register_classes 0 in + let pressure = Array.make Proc.num_register_classes 0 in Reg.Set.iter (fun r -> if Reg.Set.mem r spilled then () else begin diff --git a/asmcomp/split.ml b/asmcomp/split.ml index 919c980dce..8c553ab9ef 100644 --- a/asmcomp/split.ml +++ b/asmcomp/split.ml @@ -30,7 +30,7 @@ let subst_regs rv sub = None -> rv | Some s -> let n = Array.length rv in - let nv = Array.create n Reg.dummy in + let nv = Array.make n Reg.dummy in for i = 0 to n-1 do nv.(i) <- subst_reg rv.(i) s done; nv diff --git a/asmrun/.depend b/asmrun/.depend index 5ddaa0d396..1088ad8ed0 100644 --- a/asmrun/.depend +++ b/asmrun/.depend @@ -98,7 +98,7 @@ hash.o: hash.c ../byterun/mlvalues.h ../byterun/config.h \ ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/misc.h \ ../byterun/custom.h ../byterun/mlvalues.h ../byterun/memory.h \ ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h ../byterun/hash.h ../byterun/int64_native.h + ../byterun/minor_gc.h ../byterun/hash.h intern.o: intern.c ../byterun/alloc.h ../byterun/misc.h \ ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ ../byterun/mlvalues.h ../byterun/callback.h ../byterun/custom.h \ @@ -111,7 +111,7 @@ ints.o: ints.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ ../byterun/custom.h ../byterun/fail.h ../byterun/intext.h \ ../byterun/io.h ../byterun/memory.h ../byterun/gc.h \ ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/misc.h ../byterun/mlvalues.h ../byterun/int64_native.h + ../byterun/misc.h ../byterun/mlvalues.h io.o: io.c ../byterun/config.h ../byterun/../config/m.h \ ../byterun/../config/s.h ../byterun/alloc.h ../byterun/misc.h \ ../byterun/config.h ../byterun/mlvalues.h ../byterun/custom.h \ @@ -227,8 +227,7 @@ startup.o: startup.c ../byterun/callback.h ../byterun/mlvalues.h \ ../byterun/printexc.h stack.h ../byterun/sys.h str.o: str.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ - ../byterun/fail.h ../byterun/mlvalues.h ../byterun/misc.h \ - ../byterun/int64_native.h + ../byterun/fail.h ../byterun/mlvalues.h ../byterun/misc.h sys.o: sys.c ../byterun/config.h ../byterun/../config/m.h \ ../byterun/../config/s.h ../byterun/alloc.h ../byterun/misc.h \ ../byterun/config.h ../byterun/mlvalues.h ../byterun/debugger.h \ @@ -350,7 +349,7 @@ hash.d.o: hash.c ../byterun/mlvalues.h ../byterun/config.h \ ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/misc.h \ ../byterun/custom.h ../byterun/mlvalues.h ../byterun/memory.h \ ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h ../byterun/hash.h ../byterun/int64_native.h + ../byterun/minor_gc.h ../byterun/hash.h intern.d.o: intern.c ../byterun/alloc.h ../byterun/misc.h \ ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ ../byterun/mlvalues.h ../byterun/callback.h ../byterun/custom.h \ @@ -363,7 +362,7 @@ ints.d.o: ints.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ ../byterun/custom.h ../byterun/fail.h ../byterun/intext.h \ ../byterun/io.h ../byterun/memory.h ../byterun/gc.h \ ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/misc.h ../byterun/mlvalues.h ../byterun/int64_native.h + ../byterun/misc.h ../byterun/mlvalues.h io.d.o: io.c ../byterun/config.h ../byterun/../config/m.h \ ../byterun/../config/s.h ../byterun/alloc.h ../byterun/misc.h \ ../byterun/config.h ../byterun/mlvalues.h ../byterun/custom.h \ @@ -479,8 +478,7 @@ startup.d.o: startup.c ../byterun/callback.h ../byterun/mlvalues.h \ ../byterun/printexc.h stack.h ../byterun/sys.h str.d.o: str.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ - ../byterun/fail.h ../byterun/mlvalues.h ../byterun/misc.h \ - ../byterun/int64_native.h + ../byterun/fail.h ../byterun/mlvalues.h ../byterun/misc.h sys.d.o: sys.c ../byterun/config.h ../byterun/../config/m.h \ ../byterun/../config/s.h ../byterun/alloc.h ../byterun/misc.h \ ../byterun/config.h ../byterun/mlvalues.h ../byterun/debugger.h \ @@ -602,7 +600,7 @@ hash.p.o: hash.c ../byterun/mlvalues.h ../byterun/config.h \ ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/misc.h \ ../byterun/custom.h ../byterun/mlvalues.h ../byterun/memory.h \ ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h ../byterun/hash.h ../byterun/int64_native.h + ../byterun/minor_gc.h ../byterun/hash.h intern.p.o: intern.c ../byterun/alloc.h ../byterun/misc.h \ ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ ../byterun/mlvalues.h ../byterun/callback.h ../byterun/custom.h \ @@ -615,7 +613,7 @@ ints.p.o: ints.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ ../byterun/custom.h ../byterun/fail.h ../byterun/intext.h \ ../byterun/io.h ../byterun/memory.h ../byterun/gc.h \ ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/misc.h ../byterun/mlvalues.h ../byterun/int64_native.h + ../byterun/misc.h ../byterun/mlvalues.h io.p.o: io.c ../byterun/config.h ../byterun/../config/m.h \ ../byterun/../config/s.h ../byterun/alloc.h ../byterun/misc.h \ ../byterun/config.h ../byterun/mlvalues.h ../byterun/custom.h \ @@ -731,8 +729,7 @@ startup.p.o: startup.c ../byterun/callback.h ../byterun/mlvalues.h \ ../byterun/printexc.h stack.h ../byterun/sys.h str.p.o: str.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ - ../byterun/fail.h ../byterun/mlvalues.h ../byterun/misc.h \ - ../byterun/int64_native.h + ../byterun/fail.h ../byterun/mlvalues.h ../byterun/misc.h sys.p.o: sys.c ../byterun/config.h ../byterun/../config/m.h \ ../byterun/../config/s.h ../byterun/alloc.h ../byterun/misc.h \ ../byterun/config.h ../byterun/mlvalues.h ../byterun/debugger.h \ diff --git a/asmrun/arm.S b/asmrun/arm.S index 2ce244a1a5..9720665aa3 100644 --- a/asmrun/arm.S +++ b/asmrun/arm.S @@ -44,6 +44,15 @@ cmp \reg, #0 beq \lbl .endm +#elif defined(SYS_freebsd) + .arch armv6 + .arm + + /* Compatibility macros */ + .macro cbz reg, lbl + cmp \reg, #0 + beq \lbl + .endm #endif trap_ptr .req r8 diff --git a/asmrun/arm64.S b/asmrun/arm64.S index fa871df797..9b4b9ab7c9 100644 --- a/asmrun/arm64.S +++ b/asmrun/arm64.S @@ -83,10 +83,10 @@ caml_call_gc: PROFILE /* Record return address */ STOREGLOBAL(x30, caml_last_return_address) -.Lcaml_call_gc: /* Record lowest stack address */ mov TMP, sp STOREGLOBAL(TMP, caml_bottom_of_stack) +.Lcaml_call_gc: /* Set up stack space, saving return address and frame pointer */ /* (2 regs RA/GP, 24 allocatable int regs, 24 caller-save float regs) * 8 */ stp x29, x30, [sp, -400]! @@ -175,6 +175,13 @@ caml_alloc1: ret 2: stp x29, x30, [sp, -16]! CFI_ADJUST(16) + /* Record the lowest address of the caller's stack frame. This is the address + immediately above the pair of words (x29 and x30) we just pushed. Those must + not be included since otherwise the distance from [caml_bottom_of_stack] to the + highest address in the caller's stack frame won't match the frame size contained + in the relevant frame descriptor. */ + add x29, sp, #16 + STOREGLOBAL(x29, caml_bottom_of_stack) add x29, sp, #0 /* Record return address */ STOREGLOBAL(x30, caml_last_return_address) @@ -200,6 +207,9 @@ caml_alloc2: ret 2: stp x29, x30, [sp, -16]! CFI_ADJUST(16) + /* Record the lowest address of the caller's stack frame. See comment above. */ + add x29, sp, #16 + STOREGLOBAL(x29, caml_bottom_of_stack) add x29, sp, #0 /* Record return address */ STOREGLOBAL(x30, caml_last_return_address) @@ -225,6 +235,9 @@ caml_alloc3: ret 2: stp x29, x30, [sp, -16]! CFI_ADJUST(16) + /* Record the lowest address of the caller's stack frame. See comment above. */ + add x29, sp, #16 + STOREGLOBAL(x29, caml_bottom_of_stack) add x29, sp, #0 /* Record return address */ STOREGLOBAL(x30, caml_last_return_address) @@ -250,6 +263,9 @@ caml_allocN: ret 2: stp x29, x30, [sp, -16]! CFI_ADJUST(16) + /* Record the lowest address of the caller's stack frame. See comment above. */ + add x29, sp, #16 + STOREGLOBAL(x29, caml_bottom_of_stack) add x29, sp, #0 /* Record return address */ STOREGLOBAL(x30, caml_last_return_address) diff --git a/asmrun/backtrace.c b/asmrun/backtrace.c index c72a2373b9..773e22cd27 100644 --- a/asmrun/backtrace.c +++ b/asmrun/backtrace.c @@ -217,7 +217,7 @@ static void extract_location_info(frame_descr * d, /*out*/ struct loc_info * li) { uintnat infoptr; - uint32 info1, info2; + uint32_t info1, info2; /* If no debugging information available, print nothing. When everything is compiled with -g, this corresponds to @@ -232,8 +232,8 @@ static void extract_location_info(frame_descr * d, sizeof(char *) + sizeof(short) + sizeof(short) + sizeof(short) * d->num_live + sizeof(frame_descr *) - 1) & -sizeof(frame_descr *); - info1 = ((uint32 *)infoptr)[0]; - info2 = ((uint32 *)infoptr)[1]; + info1 = ((uint32_t *)infoptr)[0]; + info2 = ((uint32_t *)infoptr)[1]; /* Format of the two info words: llllllllllllllllllll aaaaaaaa bbbbbbbbbb nnnnnnnnnnnnnnnnnnnnnnnn kk 44 36 26 2 0 diff --git a/boot/ocamlc b/boot/ocamlc Binary files differindex 30553fc841..3a04382c58 100755 --- a/boot/ocamlc +++ b/boot/ocamlc diff --git a/boot/ocamldep b/boot/ocamldep Binary files differindex 409f30f971..e7af3bb6d7 100755 --- a/boot/ocamldep +++ b/boot/ocamldep diff --git a/boot/ocamllex b/boot/ocamllex Binary files differindex be5e1a4640..3c88f8eba6 100755 --- a/boot/ocamllex +++ b/boot/ocamllex diff --git a/bytecomp/bytegen.ml b/bytecomp/bytegen.ml index 1a3767969c..91900af156 100644 --- a/bytecomp/bytegen.ml +++ b/bytecomp/bytegen.ml @@ -721,8 +721,8 @@ let rec comp_expr env exp sz cont = (* Build indirection vectors *) let store = Storer.mk_store () in - let act_consts = Array.create sw.sw_numconsts 0 - and act_blocks = Array.create sw.sw_numblocks 0 in + let act_consts = Array.make sw.sw_numconsts 0 + and act_blocks = Array.make sw.sw_numblocks 0 in begin match sw.sw_failaction with (* default is index 0 *) | Some fail -> ignore (store.act_store fail) | None -> () @@ -744,7 +744,7 @@ let rec comp_expr env exp sz cont = | _ -> ()) a ; *) - let lbls = Array.create (Array.length acts) 0 in + let lbls = Array.make (Array.length acts) 0 in for i = Array.length acts-1 downto 0 do let lbl,c1 = label_code (comp_expr env acts.(i) sz (branch :: !c)) in lbls.(i) <- lbl ; @@ -752,11 +752,11 @@ let rec comp_expr env exp sz cont = done ; (* Build label vectors *) - let lbl_blocks = Array.create sw.sw_numblocks 0 in + let lbl_blocks = Array.make sw.sw_numblocks 0 in for i = sw.sw_numblocks - 1 downto 0 do lbl_blocks.(i) <- lbls.(act_blocks.(i)) done; - let lbl_consts = Array.create sw.sw_numconsts 0 in + let lbl_consts = Array.make sw.sw_numconsts 0 in for i = sw.sw_numconsts - 1 downto 0 do lbl_consts.(i) <- lbls.(act_consts.(i)) done; diff --git a/bytecomp/emitcode.ml b/bytecomp/emitcode.ml index 95b9a20f59..77df46110e 100644 --- a/bytecomp/emitcode.ml +++ b/bytecomp/emitcode.ml @@ -82,7 +82,7 @@ let label_table = ref ([| |] : label_definition array) let extend_label_table needed = let new_size = ref(Array.length !label_table) in while needed >= !new_size do new_size := 2 * !new_size done; - let new_table = Array.create !new_size (Label_undefined []) in + let new_table = Array.make !new_size (Label_undefined []) in Array.blit !label_table 0 new_table 0 (Array.length !label_table); label_table := new_table @@ -150,7 +150,7 @@ let record_event ev = let init () = out_position := 0; - label_table := Array.create 16 (Label_undefined []); + label_table := Array.make 16 (Label_undefined []); reloc_info := []; debug_dirs := StringSet.empty; events := [] @@ -360,7 +360,7 @@ let rec emit = function (* Emission to a file *) -let to_file outchan unit_name code = +let to_file outchan unit_name objfile code = init(); output_string outchan cmo_magic_number; let pos_depl = pos_out outchan in @@ -370,6 +370,9 @@ let to_file outchan unit_name code = LongString.output outchan !out_buffer 0 !out_position; let (pos_debug, size_debug) = if !Clflags.debug then begin + debug_dirs := StringSet.add + (Filename.dirname (Location.absolute_path objfile)) + !debug_dirs; let p = pos_out outchan in output_value outchan !events; output_value outchan (StringSet.elements !debug_dirs); diff --git a/bytecomp/emitcode.mli b/bytecomp/emitcode.mli index ee0bccbf0d..e2fdb81551 100644 --- a/bytecomp/emitcode.mli +++ b/bytecomp/emitcode.mli @@ -15,10 +15,11 @@ open Cmo_format open Instruct -val to_file: out_channel -> string -> instruction list -> unit +val to_file: out_channel -> string -> string -> instruction list -> unit (* Arguments: channel on output file name of compilation unit implemented + path of cmo file being written list of instructions to emit *) val to_memory: instruction list -> instruction list -> bytes * int * (reloc_info * int) list diff --git a/bytecomp/lambda.ml b/bytecomp/lambda.ml index 3c1aaf26bb..4ad8e9b4e1 100644 --- a/bytecomp/lambda.ml +++ b/bytecomp/lambda.ml @@ -548,4 +548,3 @@ let lam_of_loc kind loc = let reset () = raise_count := 0 - diff --git a/bytecomp/lambda.mli b/bytecomp/lambda.mli index 2448087da7..0e038d93d3 100644 --- a/bytecomp/lambda.mli +++ b/bytecomp/lambda.mli @@ -247,9 +247,10 @@ val negate_comparison : comparison -> comparison (* Get a new static failure ident *) val next_raise_count : unit -> int val next_negative_raise_count : unit -> int - (* Negative raise counts are used to compile 'match ... with exception x -> ...'. - This disabled some simplifications performed by the Simplif module that assume - that static raises are in tail position in their handler. *) + (* Negative raise counts are used to compile 'match ... with + exception x -> ...'. This disabled some simplifications + performed by the Simplif module that assume that static raises + are in tail position in their handler. *) val staticfail : lambda (* Anticipated static failure *) diff --git a/bytecomp/matching.ml b/bytecomp/matching.ml index 5a8f71efcd..dfaee2c718 100644 --- a/bytecomp/matching.ml +++ b/bytecomp/matching.ml @@ -1606,7 +1606,7 @@ let divide_tuple arity p ctx pm = let record_matching_line num_fields lbl_pat_list = - let patv = Array.create num_fields omega in + let patv = Array.make num_fields omega in List.iter (fun (_, lbl, pat) -> patv.(lbl.lbl_pos) <- pat) lbl_pat_list; Array.to_list patv @@ -1896,7 +1896,7 @@ let rec explode_inter offset i j act k = k let max_vals cases acts = - let vals = Array.create (Array.length acts) 0 in + let vals = Array.make (Array.length acts) 0 in for i=Array.length cases-1 downto 0 do let l,h,act = cases.(i) in vals.(act) <- h - l + 1 + vals.(act) diff --git a/bytecomp/switch.ml b/bytecomp/switch.ml index 4a4e0691c8..da9a48f1a9 100644 --- a/bytecomp/switch.ml +++ b/bytecomp/switch.ml @@ -248,7 +248,7 @@ let case_append c1 c2 = let l1,h1,act1 = c1.(Array.length c1-1) and l2,h2,act2 = c2.(0) in if act1 = act2 then - let r = Array.create (len1+len2-1) c1.(0) in + let r = Array.make (len1+len2-1) c1.(0) in for i = 0 to len1-2 do r.(i) <- c1.(i) done ; @@ -277,7 +277,7 @@ let case_append c1 c2 = done ; r else if h1 > l1 then - let r = Array.create (len1+len2) c1.(0) in + let r = Array.make (len1+len2) c1.(0) in for i = 0 to len1-2 do r.(i) <- c1.(i) done ; @@ -287,7 +287,7 @@ let case_append c1 c2 = done ; r else if h2 > l2 then - let r = Array.create (len1+len2) c1.(0) in + let r = Array.make (len1+len2) c1.(0) in for i = 0 to len1-1 do r.(i) <- c1.(i) done ; @@ -728,8 +728,8 @@ let dense {cases=cases ; actions=actions} i j = let comp_clusters ({cases=cases ; actions=actions} as s) = let len = Array.length cases in - let min_clusters = Array.create len max_int - and k = Array.create len 0 in + let min_clusters = Array.make len max_int + and k = Array.make len 0 in let get_min i = if i < 0 then 0 else min_clusters.(i) in for i = 0 to len-1 do @@ -749,7 +749,7 @@ let comp_clusters ({cases=cases ; actions=actions} as s) = let make_switch {cases=cases ; actions=actions} i j = let ll,_,_ = cases.(i) and _,hh,_ = cases.(j) in - let tbl = Array.create (hh-ll+1) 0 + let tbl = Array.make (hh-ll+1) 0 and t = Hashtbl.create 17 and index = ref 0 in let get_index act = @@ -769,7 +769,7 @@ let make_switch {cases=cases ; actions=actions} i j = tbl.(kk) <- index done done ; - let acts = Array.create !index actions.(0) in + let acts = Array.make !index actions.(0) in Hashtbl.iter (fun act i -> acts.(i) <- actions.(act)) t ; @@ -784,7 +784,7 @@ let make_switch {cases=cases ; actions=actions} i j = let make_clusters ({cases=cases ; actions=actions} as s) n_clusters k = let len = Array.length cases in - let r = Array.create n_clusters (0,0,0) + let r = Array.make n_clusters (0,0,0) and t = Hashtbl.create 17 and index = ref 0 and bidon = ref (Array.length actions) in @@ -820,7 +820,7 @@ let make_clusters ({cases=cases ; actions=actions} as s) n_clusters k = if i > 0 then zyva (i-1) (ir-1) in zyva (len-1) (n_clusters-1) ; - let acts = Array.create !index (fun _ -> assert false) in + let acts = Array.make !index (fun _ -> assert false) in Hashtbl.iter (fun _ (i,act) -> acts.(i) <- act) t ; {cases = r ; actions = acts} ;; diff --git a/bytecomp/symtable.ml b/bytecomp/symtable.ml index 37609d7751..1cc3a5314d 100644 --- a/bytecomp/symtable.ml +++ b/bytecomp/symtable.ml @@ -96,7 +96,7 @@ let require_primitive name = if name.[0] <> '%' then ignore(num_of_prim name) let all_primitives () = - let prim = Array.create !c_prim_table.num_cnt "" in + let prim = Array.make !c_prim_table.num_cnt "" in Tbl.iter (fun name number -> prim.(number) <- name) !c_prim_table.num_tbl; prim @@ -226,7 +226,7 @@ let rec transl_const = function (* Build the initial table of globals *) let initial_global_table () = - let glob = Array.create !global_table.num_cnt (Obj.repr 0) in + let glob = Array.make !global_table.num_cnt (Obj.repr 0) in List.iter (fun (slot, cst) -> glob.(slot) <- transl_const cst) !literal_table; @@ -300,7 +300,8 @@ let init_toplevel () = Dll.init_toplevel dllpath; (* Recover CRC infos for interfaces *) let crcintfs = - try (Obj.magic (sect.read_struct "CRCS") : (string * Digest.t option) list) + try + (Obj.magic (sect.read_struct "CRCS") : (string * Digest.t option) list) with Not_found -> [] in (* Done *) sect.close_reader(); diff --git a/bytecomp/translclass.ml b/bytecomp/translclass.ml index 2363bd8fb6..0fb68457b0 100644 --- a/bytecomp/translclass.ml +++ b/bytecomp/translclass.ml @@ -145,7 +145,7 @@ let rec build_object_init cl_table obj params inh_init obj_init cl = | Tcf_val (_, _, id, Tcfk_concrete (_, exp), _) -> (inh_init, lsequence (set_inst_var obj id exp) obj_init, has_init) - | Tcf_method _ | Tcf_val _ | Tcf_constraint _ | Tcf_attribute _ -> + | Tcf_method _ | Tcf_val _ | Tcf_constraint _ | Tcf_attribute _-> (inh_init, obj_init, has_init) | Tcf_initializer _ -> (inh_init, obj_init, true) diff --git a/bytecomp/translcore.ml b/bytecomp/translcore.ml index f21f8c071e..dc418f1887 100644 --- a/bytecomp/translcore.ml +++ b/bytecomp/translcore.ml @@ -1088,7 +1088,7 @@ and transl_record env all_labels repres lbl_expr_list opt_init_expr = then begin (* Allocate new record with given fields (and remaining fields taken from init_expr if any *) - let lv = Array.create (Array.length all_labels) staticfail in + let lv = Array.make (Array.length all_labels) staticfail in let init_id = Ident.create "init" in begin match opt_init_expr with None -> () @@ -1176,7 +1176,7 @@ and transl_match e arg pat_expr_list exn_pat_expr_list partial = | {exp_desc = Texp_tuple argl}, _ :: _ -> let val_ids = List.map (fun _ -> name_pattern "val" []) argl in let lvars = List.map (fun id -> Lvar id) val_ids in - static_catch (transl_list argl) val_ids + static_catch (transl_list argl) val_ids (Matching.for_multiple_match e.exp_loc lvars cases partial) | arg, [] -> Matching.for_function e.exp_loc None (transl_exp arg) cases partial diff --git a/bytecomp/translmod.ml b/bytecomp/translmod.ml index 01ca31caf3..dc7d2d7a63 100644 --- a/bytecomp/translmod.ml +++ b/bytecomp/translmod.ml @@ -145,6 +145,19 @@ let rec compose_coercions c1 c2 = | (_, _) -> fatal_error "Translmod.compose_coercions" +(* +let apply_coercion a b c = + Format.eprintf "@[<2>apply_coercion@ %a@]@." Includemod.print_coercion b; + apply_coercion a b c + +let compose_coercions c1 c2 = + let c3 = compose_coercions c1 c2 in + let open Includemod in + Format.eprintf "@[<2>compose_coercions@ (%a)@ (%a) =@ %a@]@." + print_coercion c1 print_coercion c2 print_coercion c2; + c3 +*) + (* Record the primitive declarations occuring in the module compiled *) let primitive_declarations = ref ([] : Primitive.description list) @@ -225,7 +238,7 @@ let reorder_rec_bindings bindings = and rhs = Array.of_list (List.map (fun (_,_,_,rhs) -> rhs) bindings) in let fv = Array.map Lambda.free_variables rhs in let num_bindings = Array.length id in - let status = Array.create num_bindings Undefined in + let status = Array.make num_bindings Undefined in let res = ref [] in let rec emit_binding i = match status.(i) with diff --git a/byterun/.depend b/byterun/.depend index 2f1780db9e..743737d052 100644 --- a/byterun/.depend +++ b/byterun/.depend @@ -7,7 +7,7 @@ array.o: array.c alloc.h compatibility.h misc.h config.h ../config/m.h \ backtrace.o: backtrace.c config.h ../config/m.h ../config/s.h \ compatibility.h mlvalues.h misc.h alloc.h io.h instruct.h intext.h \ exec.h fix_code.h memory.h gc.h major_gc.h freelist.h minor_gc.h \ - startup.h stacks.h sys.h backtrace.h + startup.h stacks.h sys.h backtrace.h fail.h callback.o: callback.c callback.h compatibility.h mlvalues.h config.h \ ../config/m.h ../config/s.h misc.h fail.h memory.h gc.h major_gc.h \ freelist.h minor_gc.h interp.h instruct.h fix_code.h stacks.h @@ -55,7 +55,7 @@ globroots.o: globroots.c memory.h compatibility.h config.h ../config/m.h \ roots.h globroots.h hash.o: hash.c mlvalues.h compatibility.h config.h ../config/m.h \ ../config/s.h misc.h custom.h memory.h gc.h major_gc.h freelist.h \ - minor_gc.h hash.h int64_native.h + minor_gc.h hash.h instrtrace.o: instrtrace.c intern.o: intern.c alloc.h compatibility.h misc.h config.h ../config/m.h \ ../config/s.h mlvalues.h callback.h custom.h fail.h gc.h intext.h io.h \ @@ -66,7 +66,7 @@ interp.o: interp.c alloc.h compatibility.h misc.h config.h ../config/m.h \ memory.h gc.h minor_gc.h prims.h signals.h stacks.h jumptbl.h ints.o: ints.c alloc.h compatibility.h misc.h config.h ../config/m.h \ ../config/s.h mlvalues.h custom.h fail.h intext.h io.h memory.h gc.h \ - major_gc.h freelist.h minor_gc.h int64_native.h + major_gc.h freelist.h minor_gc.h io.o: io.c config.h ../config/m.h ../config/s.h compatibility.h alloc.h \ misc.h mlvalues.h custom.h fail.h io.h memory.h gc.h major_gc.h \ freelist.h minor_gc.h signals.h sys.h @@ -123,7 +123,7 @@ startup.o: startup.c config.h ../config/m.h ../config/s.h compatibility.h \ prims.h printexc.h reverse.h signals.h stacks.h sys.h startup.h \ version.h str.o: str.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h fail.h int64_native.h + ../config/s.h mlvalues.h fail.h sys.o: sys.c config.h ../config/m.h ../config/s.h compatibility.h alloc.h \ misc.h mlvalues.h debugger.h fail.h instruct.h osdeps.h signals.h \ stacks.h memory.h gc.h major_gc.h freelist.h minor_gc.h sys.h @@ -147,7 +147,7 @@ array.d.o: array.c alloc.h compatibility.h misc.h config.h ../config/m.h \ backtrace.d.o: backtrace.c config.h ../config/m.h ../config/s.h \ compatibility.h mlvalues.h misc.h alloc.h io.h instruct.h intext.h \ exec.h fix_code.h memory.h gc.h major_gc.h freelist.h minor_gc.h \ - startup.h stacks.h sys.h backtrace.h + startup.h stacks.h sys.h backtrace.h fail.h callback.d.o: callback.c callback.h compatibility.h mlvalues.h config.h \ ../config/m.h ../config/s.h misc.h fail.h memory.h gc.h major_gc.h \ freelist.h minor_gc.h interp.h instruct.h fix_code.h stacks.h @@ -195,7 +195,7 @@ globroots.d.o: globroots.c memory.h compatibility.h config.h ../config/m.h \ roots.h globroots.h hash.d.o: hash.c mlvalues.h compatibility.h config.h ../config/m.h \ ../config/s.h misc.h custom.h memory.h gc.h major_gc.h freelist.h \ - minor_gc.h hash.h int64_native.h + minor_gc.h hash.h instrtrace.d.o: instrtrace.c instruct.h misc.h compatibility.h config.h \ ../config/m.h ../config/s.h mlvalues.h opnames.h prims.h stacks.h \ memory.h gc.h major_gc.h freelist.h minor_gc.h @@ -208,7 +208,7 @@ interp.d.o: interp.c alloc.h compatibility.h misc.h config.h ../config/m.h \ memory.h gc.h minor_gc.h prims.h signals.h stacks.h ints.d.o: ints.c alloc.h compatibility.h misc.h config.h ../config/m.h \ ../config/s.h mlvalues.h custom.h fail.h intext.h io.h memory.h gc.h \ - major_gc.h freelist.h minor_gc.h int64_native.h + major_gc.h freelist.h minor_gc.h io.d.o: io.c config.h ../config/m.h ../config/s.h compatibility.h alloc.h \ misc.h mlvalues.h custom.h fail.h io.h memory.h gc.h major_gc.h \ freelist.h minor_gc.h signals.h sys.h @@ -265,7 +265,7 @@ startup.d.o: startup.c config.h ../config/m.h ../config/s.h compatibility.h \ prims.h printexc.h reverse.h signals.h stacks.h sys.h startup.h \ version.h str.d.o: str.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h fail.h int64_native.h + ../config/s.h mlvalues.h fail.h sys.d.o: sys.c config.h ../config/m.h ../config/s.h compatibility.h alloc.h \ misc.h mlvalues.h debugger.h fail.h instruct.h osdeps.h signals.h \ stacks.h memory.h gc.h major_gc.h freelist.h minor_gc.h sys.h @@ -289,7 +289,7 @@ array.pic.o: array.c alloc.h compatibility.h misc.h config.h ../config/m.h \ backtrace.pic.o: backtrace.c config.h ../config/m.h ../config/s.h \ compatibility.h mlvalues.h misc.h alloc.h io.h instruct.h intext.h \ exec.h fix_code.h memory.h gc.h major_gc.h freelist.h minor_gc.h \ - startup.h stacks.h sys.h backtrace.h + startup.h stacks.h sys.h backtrace.h fail.h callback.pic.o: callback.c callback.h compatibility.h mlvalues.h config.h \ ../config/m.h ../config/s.h misc.h fail.h memory.h gc.h major_gc.h \ freelist.h minor_gc.h interp.h instruct.h fix_code.h stacks.h @@ -337,7 +337,7 @@ globroots.pic.o: globroots.c memory.h compatibility.h config.h ../config/m.h \ roots.h globroots.h hash.pic.o: hash.c mlvalues.h compatibility.h config.h ../config/m.h \ ../config/s.h misc.h custom.h memory.h gc.h major_gc.h freelist.h \ - minor_gc.h hash.h int64_native.h + minor_gc.h hash.h instrtrace.pic.o: instrtrace.c intern.pic.o: intern.c alloc.h compatibility.h misc.h config.h ../config/m.h \ ../config/s.h mlvalues.h callback.h custom.h fail.h gc.h intext.h io.h \ @@ -348,7 +348,7 @@ interp.pic.o: interp.c alloc.h compatibility.h misc.h config.h ../config/m.h \ memory.h gc.h minor_gc.h prims.h signals.h stacks.h jumptbl.h ints.pic.o: ints.c alloc.h compatibility.h misc.h config.h ../config/m.h \ ../config/s.h mlvalues.h custom.h fail.h intext.h io.h memory.h gc.h \ - major_gc.h freelist.h minor_gc.h int64_native.h + major_gc.h freelist.h minor_gc.h io.pic.o: io.c config.h ../config/m.h ../config/s.h compatibility.h alloc.h \ misc.h mlvalues.h custom.h fail.h io.h memory.h gc.h major_gc.h \ freelist.h minor_gc.h signals.h sys.h @@ -405,7 +405,7 @@ startup.pic.o: startup.c config.h ../config/m.h ../config/s.h compatibility.h \ prims.h printexc.h reverse.h signals.h stacks.h sys.h startup.h \ version.h str.pic.o: str.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h fail.h int64_native.h + ../config/s.h mlvalues.h fail.h sys.pic.o: sys.c config.h ../config/m.h ../config/s.h compatibility.h alloc.h \ misc.h mlvalues.h debugger.h fail.h instruct.h osdeps.h signals.h \ stacks.h memory.h gc.h major_gc.h freelist.h minor_gc.h sys.h diff --git a/byterun/alloc.h b/byterun/alloc.h index f00a7ef0eb..2a640ebe6a 100644 --- a/byterun/alloc.h +++ b/byterun/alloc.h @@ -32,8 +32,8 @@ CAMLextern value caml_alloc_string (mlsize_t); /* size in bytes */ CAMLextern value caml_copy_string (char const *); CAMLextern value caml_copy_string_array (char const **); CAMLextern value caml_copy_double (double); -CAMLextern value caml_copy_int32 (int32); /* defined in [ints.c] */ -CAMLextern value caml_copy_int64 (int64); /* defined in [ints.c] */ +CAMLextern value caml_copy_int32 (int32_t); /* defined in [ints.c] */ +CAMLextern value caml_copy_int64 (int64_t); /* defined in [ints.c] */ CAMLextern value caml_copy_nativeint (intnat); /* defined in [ints.c] */ CAMLextern value caml_alloc_array (value (*funct) (char const *), char const ** array); diff --git a/byterun/backtrace.c b/byterun/backtrace.c index 9b8022a306..6ed56c840b 100644 --- a/byterun/backtrace.c +++ b/byterun/backtrace.c @@ -229,7 +229,7 @@ static void read_debug_info(void) int fd; struct exec_trailer trail; struct channel * chan; - uint32 num_events, orig, i; + uint32_t num_events, orig, i; intnat j; value evl, l, ev_start; @@ -298,7 +298,8 @@ static void read_debug_info(void) read_debug_info_error = "out of memory"; CAMLreturn0; } - memcpy(events[j].ev_filename, String_val (Field (ev_start, POS_FNAME)), fnsz); + memcpy(events[j].ev_filename, String_val (Field (ev_start, POS_FNAME)), + fnsz); events[j].ev_lnum = Int_val (Field (ev_start, POS_LNUM)); events[j].ev_startchr = diff --git a/byterun/config.h b/byterun/config.h index f77598850c..6c86d1672a 100644 --- a/byterun/config.h +++ b/byterun/config.h @@ -25,24 +25,30 @@ #include "compatibility.h" #endif -/* Types for 32-bit integers, 64-bit integers, +#ifdef HAS_STDINT_H +#include <stdint.h> +#endif + +/* Types for 32-bit integers, 64-bit integers, and native integers (as wide as a pointer type) */ +#ifndef ARCH_INT32_TYPE #if SIZEOF_INT == 4 -typedef int int32; -typedef unsigned int uint32; +#define ARCH_INT32_TYPE int +#define ARCH_UINT32_TYPE unsigned int #define ARCH_INT32_PRINTF_FORMAT "" #elif SIZEOF_LONG == 4 -typedef long int32; -typedef unsigned long uint32; +#define ARCH_INT32_TYPE long +#define ARCH_UINT32_TYPE unsigned long #define ARCH_INT32_PRINTF_FORMAT "l" #elif SIZEOF_SHORT == 4 -typedef short int32; -typedef unsigned short uint32; +#define ARCH_INT32_TYPE short +#define ARCH_UINT32_TYPE unsigned short #define ARCH_INT32_PRINTF_FORMAT "" #else #error "No 32-bit integer type available" #endif +#endif #ifndef ARCH_INT64_TYPE #if SIZEOF_LONGLONG == 8 @@ -58,8 +64,13 @@ typedef unsigned short uint32; #endif #endif -typedef ARCH_INT64_TYPE int64; -typedef ARCH_UINT64_TYPE uint64; +#ifndef HAS_STDINT_H +/* Not a C99 compiler, typically MSVC. Define the C99 types we use. */ +typedef ARCH_INT32_TYPE int32_t; +typedef ARCH_UINT32_TYPE uint32_t; +typedef ARCH_INT64_TYPE int64_t; +typedef ARCH_UINT64_TYPE uint64_t; +#endif #if SIZEOF_PTR == SIZEOF_LONG /* Standard models: ILP32 or I32LP64 */ @@ -72,9 +83,9 @@ typedef int intnat; typedef unsigned int uintnat; #define ARCH_INTNAT_PRINTF_FORMAT "" #elif SIZEOF_PTR == 8 -/* Win64 model: IL32LLP64 */ -typedef int64 intnat; -typedef uint64 uintnat; +/* Win64 model: IL32P64 */ +typedef int64_t intnat; +typedef uint64_t uintnat; #define ARCH_INTNAT_PRINTF_FORMAT ARCH_INT64_PRINTF_FORMAT #else #error "No integer type available to represent pointers" diff --git a/byterun/debugger.h b/byterun/debugger.h index b5079eb3ba..e68ef756c1 100644 --- a/byterun/debugger.h +++ b/byterun/debugger.h @@ -37,17 +37,17 @@ void caml_debugger_cleanup_fork (void); /* Requests from the debugger to the runtime system */ enum debugger_request { - REQ_SET_EVENT = 'e', /* uint32 pos */ + REQ_SET_EVENT = 'e', /* uint32_t pos */ /* Set an event on the instruction at position pos */ - REQ_SET_BREAKPOINT = 'B', /* uint32 pos, (char k) */ + REQ_SET_BREAKPOINT = 'B', /* uint32_t pos, (char k) */ /* Set a breakpoint at position pos */ /* In profiling mode, the breakpoint kind is set to k */ - REQ_RESET_INSTR = 'i', /* uint32 pos */ + REQ_RESET_INSTR = 'i', /* uint32_t pos */ /* Clear an event or breapoint at position pos, restores initial instr. */ REQ_CHECKPOINT = 'c', /* no args */ /* Checkpoint the runtime system by forking a child process. Reply is pid of child process or -1 if checkpoint failed. */ - REQ_GO = 'g', /* uint32 n */ + REQ_GO = 'g', /* uint32_t n */ /* Run the program for n events. Reply is one of debugger_reply described below. */ REQ_STOP = 's', /* no args */ @@ -59,38 +59,38 @@ enum debugger_request { Reply is stack offset and current pc. */ REQ_GET_FRAME = 'f', /* no args */ /* Return current frame location (stack offset + current pc). */ - REQ_SET_FRAME = 'S', /* uint32 stack_offset */ + REQ_SET_FRAME = 'S', /* uint32_t stack_offset */ /* Set current frame to given stack offset. No reply. */ - REQ_UP_FRAME = 'U', /* uint32 n */ + REQ_UP_FRAME = 'U', /* uint32_t n */ /* Move one frame up. Argument n is size of current frame (in words). Reply is stack offset and current pc, or -1 if top of stack reached. */ - REQ_SET_TRAP_BARRIER = 'b', /* uint32 offset */ + REQ_SET_TRAP_BARRIER = 'b', /* uint32_t offset */ /* Set the trap barrier at the given offset. */ - REQ_GET_LOCAL = 'L', /* uint32 slot_number */ + REQ_GET_LOCAL = 'L', /* uint32_t slot_number */ /* Return the local variable at the given slot in the current frame. Reply is one value. */ - REQ_GET_ENVIRONMENT = 'E', /* uint32 slot_number */ + REQ_GET_ENVIRONMENT = 'E', /* uint32_t slot_number */ /* Return the local variable at the given slot in the heap environment of the current frame. Reply is one value. */ - REQ_GET_GLOBAL = 'G', /* uint32 global_number */ + REQ_GET_GLOBAL = 'G', /* uint32_t global_number */ /* Return the specified global variable. Reply is one value. */ REQ_GET_ACCU = 'A', /* no args */ /* Return the current contents of the accumulator. Reply is one value. */ REQ_GET_HEADER = 'H', /* mlvalue v */ /* As REQ_GET_OBJ, but sends only the header. */ - REQ_GET_FIELD = 'F', /* mlvalue v, uint32 fieldnum */ + REQ_GET_FIELD = 'F', /* mlvalue v, uint32_t fieldnum */ /* As REQ_GET_OBJ, but sends only one field. */ REQ_MARSHAL_OBJ = 'M', /* mlvalue v */ /* Send a copy of the data structure rooted at v, using the same format as [caml_output_value]. */ REQ_GET_CLOSURE_CODE = 'C', /* mlvalue v */ /* Send the code address of the given closure. - Reply is one uint32. */ - REQ_SET_FORK_MODE = 'K' /* uint32 m */ + Reply is one uint32_t. */ + REQ_SET_FORK_MODE = 'K' /* uint32_t m */ /* Set whether to follow the child (m=0) or the parent on fork. */ }; -/* Replies to a REQ_GO request. All replies are followed by three uint32: +/* Replies to a REQ_GO request. All replies are followed by three uint32_t: - the value of the event counter - the position of the stack - the current pc. */ diff --git a/byterun/exec.h b/byterun/exec.h index a58bcf8b39..7e084acd41 100644 --- a/byterun/exec.h +++ b/byterun/exec.h @@ -39,13 +39,13 @@ struct section_descriptor { char name[4]; /* Section name */ - uint32 len; /* Length of data in bytes */ + uint32_t len; /* Length of data in bytes */ }; /* Structure of the trailer. */ struct exec_trailer { - uint32 num_sections; /* Number of sections */ + uint32_t num_sections; /* Number of sections */ char magic[12]; /* The magic number */ struct section_descriptor * section; /* Not part of file */ }; diff --git a/byterun/extern.c b/byterun/extern.c index deb8209bad..f1ebddef37 100644 --- a/byterun/extern.c +++ b/byterun/extern.c @@ -720,7 +720,7 @@ CAMLexport void caml_serialize_int_2(int i) extern_ptr += 2; } -CAMLexport void caml_serialize_int_4(int32 i) +CAMLexport void caml_serialize_int_4(int32_t i) { if (extern_ptr + 4 > extern_limit) grow_extern_output(4); extern_ptr[0] = i >> 24; @@ -730,7 +730,7 @@ CAMLexport void caml_serialize_int_4(int32 i) extern_ptr += 4; } -CAMLexport void caml_serialize_int_8(int64 i) +CAMLexport void caml_serialize_int_8(int64_t i) { caml_serialize_block_8(&i, 1); } diff --git a/byterun/fix_code.c b/byterun/fix_code.c index 3380dc9195..4fa027502a 100644 --- a/byterun/fix_code.c +++ b/byterun/fix_code.c @@ -134,12 +134,12 @@ void caml_thread_code (code_t code, asize_t len) } *p++ = (opcode_t)(caml_instr_table[instr] - caml_instr_base); if (instr == SWITCH) { - uint32 sizes = *p++; - uint32 const_size = sizes & 0xFFFF; - uint32 block_size = sizes >> 16; + uint32_t sizes = *p++; + uint32_t const_size = sizes & 0xFFFF; + uint32_t block_size = sizes >> 16; p += const_size + block_size; } else if (instr == CLOSUREREC) { - uint32 nfuncs = *p++; + uint32_t nfuncs = *p++; p++; /* skip nvars */ p += nfuncs; } else { diff --git a/byterun/floats.c b/byterun/floats.c index 7ff6d89ddd..d8fdd054bf 100644 --- a/byterun/floats.c +++ b/byterun/floats.c @@ -378,9 +378,9 @@ CAMLprim value caml_log1p_float(value f) union double_as_two_int32 { double d; #if defined(ARCH_BIG_ENDIAN) || (defined(__arm__) && !defined(__ARM_EABI__)) - struct { uint32 h; uint32 l; } i; + struct { uint32_t h; uint32_t l; } i; #else - struct { uint32 l; uint32 h; } i; + struct { uint32_t l; uint32_t h; } i; #endif }; @@ -467,7 +467,7 @@ CAMLprim value caml_classify_float(value vd) } #else union double_as_two_int32 u; - uint32 h, l; + uint32_t h, l; u.d = Double_val(vd); h = u.i.h; l = u.i.l; diff --git a/byterun/gc_ctrl.c b/byterun/gc_ctrl.c index 7e61f0c1b6..1ab099da9e 100644 --- a/byterun/gc_ctrl.c +++ b/byterun/gc_ctrl.c @@ -321,7 +321,7 @@ CAMLprim value caml_gc_get(value v) res = caml_alloc_tuple (7); Store_field (res, 0, Val_long (Wsize_bsize (caml_minor_heap_size))); /* s */ - Store_field (res, 1,Val_long(Wsize_bsize(caml_major_heap_increment)));/* i */ + Store_field (res, 1, Val_long (caml_major_heap_increment)); /* i */ Store_field (res, 2, Val_long (caml_percent_free)); /* o */ Store_field (res, 3, Val_long (caml_verb_gc)); /* v */ Store_field (res, 4, Val_long (caml_percent_max)); /* O */ diff --git a/byterun/globroots.c b/byterun/globroots.c index ded393e893..d9111eefee 100644 --- a/byterun/globroots.c +++ b/byterun/globroots.c @@ -43,11 +43,11 @@ struct global_root_list { (i.e. 2 * (NUM_LEVELS - 1)). Moreover, the congruential PRNG is faster and guaranteed to be deterministic (to reproduce bugs). */ -static uint32 random_seed = 0; +static uint32_t random_seed = 0; static int random_level(void) { - uint32 r; + uint32_t r; int level = 0; /* Linear congruence with modulus = 2^32, multiplier = 69069 diff --git a/byterun/hash.c b/byterun/hash.c index f8964265db..12912d3d2f 100644 --- a/byterun/hash.c +++ b/byterun/hash.c @@ -41,7 +41,7 @@ h *= 0xc2b2ae35; \ h ^= h >> 16; -CAMLexport uint32 caml_hash_mix_uint32(uint32 h, uint32 d) +CAMLexport uint32_t caml_hash_mix_uint32(uint32_t h, uint32_t d) { MIX(h, d); return h; @@ -49,17 +49,17 @@ CAMLexport uint32 caml_hash_mix_uint32(uint32 h, uint32 d) /* Mix a platform-native integer. */ -CAMLexport uint32 caml_hash_mix_intnat(uint32 h, intnat d) +CAMLexport uint32_t caml_hash_mix_intnat(uint32_t h, intnat d) { - uint32 n; + uint32_t n; #ifdef ARCH_SIXTYFOUR /* Mix the low 32 bits and the high 32 bits, in a way that preserves - 32/64 compatibility: we want n = (uint32) d + 32/64 compatibility: we want n = (uint32_t) d if d is in the range [-2^31, 2^31-1]. */ n = (d >> 32) ^ (d >> 63) ^ d; /* If 0 <= d < 2^31: d >> 32 = 0 d >> 63 = 0 If -2^31 <= d < 0: d >> 32 = -1 d >> 63 = -1 - In both cases, n = (uint32) d. */ + In both cases, n = (uint32_t) d. */ #else n = d; #endif @@ -69,9 +69,9 @@ CAMLexport uint32 caml_hash_mix_intnat(uint32 h, intnat d) /* Mix a 64-bit integer. */ -CAMLexport uint32 caml_hash_mix_int64(uint32 h, int64 d) +CAMLexport uint32_t caml_hash_mix_int64(uint32_t h, int64_t d) { - uint32 hi = (uint32) (d >> 32), lo = (uint32) d; + uint32_t hi = (uint32_t) (d >> 32), lo = (uint32_t) d; MIX(h, lo); MIX(h, hi); return h; @@ -82,17 +82,17 @@ CAMLexport uint32 caml_hash_mix_int64(uint32 h, int64 d) Treats all NaNs identically. */ -CAMLexport uint32 caml_hash_mix_double(uint32 hash, double d) +CAMLexport uint32_t caml_hash_mix_double(uint32_t hash, double d) { union { double d; #if defined(ARCH_BIG_ENDIAN) || (defined(__arm__) && !defined(__ARM_EABI__)) - struct { uint32 h; uint32 l; } i; + struct { uint32_t h; uint32_t l; } i; #else - struct { uint32 l; uint32 h; } i; + struct { uint32_t l; uint32_t h; } i; #endif } u; - uint32 h, l; + uint32_t h, l; /* Convert to two 32-bit halves */ u.d = d; h = u.i.h; l = u.i.l; @@ -115,14 +115,14 @@ CAMLexport uint32 caml_hash_mix_double(uint32 hash, double d) Treats all NaNs identically. */ -CAMLexport uint32 caml_hash_mix_float(uint32 hash, float d) +CAMLexport uint32_t caml_hash_mix_float(uint32_t hash, float d) { union { float f; - uint32 i; + uint32_t i; } u; - uint32 n; - /* Convert to int32 */ + uint32_t n; + /* Convert to int32_t */ u.f = d; n = u.i; /* Normalize NaNs */ if ((n & 0x7F800000) == 0x7F800000 && (n & 0x007FFFFF) != 0) { @@ -138,11 +138,11 @@ CAMLexport uint32 caml_hash_mix_float(uint32 hash, float d) /* Mix an OCaml string */ -CAMLexport uint32 caml_hash_mix_string(uint32 h, value s) +CAMLexport uint32_t caml_hash_mix_string(uint32_t h, value s) { mlsize_t len = caml_string_length(s); mlsize_t i; - uint32 w; + uint32_t w; /* Mix by 32-bit blocks (little-endian) */ for (i = 0; i + 4 <= len; i += 4) { @@ -152,7 +152,7 @@ CAMLexport uint32 caml_hash_mix_string(uint32 h, value s) | (Byte_u(s, i+2) << 16) | (Byte_u(s, i+3) << 24); #else - w = *((uint32 *) &Byte_u(s, i)); + w = *((uint32_t *) &Byte_u(s, i)); #endif MIX(h, w); } @@ -166,7 +166,7 @@ CAMLexport uint32 caml_hash_mix_string(uint32 h, value s) default: /*skip*/; /* len & 3 == 0, no extra bytes, do nothing */ } /* Finally, mix in the length. Ignore the upper 32 bits, generally 0. */ - h ^= (uint32) len; + h ^= (uint32_t) len; return h; } @@ -184,7 +184,7 @@ CAMLprim value caml_hash(value count, value limit, value seed, value obj) intnat wr; /* One past position of last value in queue */ intnat sz; /* Max number of values to put in queue */ intnat num; /* Max number of meaningful values to see */ - uint32 h; /* Rolling hash */ + uint32_t h; /* Rolling hash */ value v; mlsize_t i, len; @@ -245,7 +245,7 @@ CAMLprim value caml_hash(value count, value limit, value seed, value obj) /* If no hashing function provided, do nothing. */ /* Only use low 32 bits of custom hash, for 32/64 compatibility */ if (Custom_ops_val(v)->hash != NULL) { - uint32 n = (uint32) Custom_ops_val(v)->hash(v); + uint32_t n = (uint32_t) Custom_ops_val(v)->hash(v); h = caml_hash_mix_uint32(h, n); num--; } @@ -408,5 +408,5 @@ CAMLexport value caml_hash_variant(char const * tag) #endif /* Force sign extension of bit 31 for compatibility between 32 and 64-bit platforms */ - return (int32) accu; + return (int32_t) accu; } diff --git a/byterun/hash.h b/byterun/hash.h index 436a8bb167..65613975b8 100644 --- a/byterun/hash.h +++ b/byterun/hash.h @@ -18,12 +18,12 @@ #include "mlvalues.h" -CAMLextern uint32 caml_hash_mix_uint32(uint32 h, uint32 d); -CAMLextern uint32 caml_hash_mix_intnat(uint32 h, intnat d); -CAMLextern uint32 caml_hash_mix_int64(uint32 h, int64 d); -CAMLextern uint32 caml_hash_mix_double(uint32 h, double d); -CAMLextern uint32 caml_hash_mix_float(uint32 h, float d); -CAMLextern uint32 caml_hash_mix_string(uint32 h, value s); +CAMLextern uint32_t caml_hash_mix_uint32(uint32_t h, uint32_t d); +CAMLextern uint32_t caml_hash_mix_intnat(uint32_t h, intnat d); +CAMLextern uint32_t caml_hash_mix_int64(uint32_t h, int64_t d); +CAMLextern uint32_t caml_hash_mix_double(uint32_t h, double d); +CAMLextern uint32_t caml_hash_mix_float(uint32_t h, float d); +CAMLextern uint32_t caml_hash_mix_string(uint32_t h, value s); #endif diff --git a/byterun/int64_emul.h b/byterun/int64_emul.h index ba7904a4fe..2554df1814 100644 --- a/byterun/int64_emul.h +++ b/byterun/int64_emul.h @@ -28,7 +28,7 @@ #define I64_split(x,hi,lo) (hi = (x).h, lo = (x).l) /* Unsigned comparison */ -static int I64_ucompare(uint64 x, uint64 y) +static int I64_ucompare(uint64_t x, uint64_t y) { if (x.h > y.h) return 1; if (x.h < y.h) return -1; @@ -40,19 +40,19 @@ static int I64_ucompare(uint64 x, uint64 y) #define I64_ult(x, y) (I64_ucompare(x, y) < 0) /* Signed comparison */ -static int I64_compare(int64 x, int64 y) +static int I64_compare(int64_t x, int64_t y) { - if ((int32)x.h > (int32)y.h) return 1; - if ((int32)x.h < (int32)y.h) return -1; + if ((int32_t)x.h > (int32_t)y.h) return 1; + if ((int32_t)x.h < (int32_t)y.h) return -1; if (x.l > y.l) return 1; if (x.l < y.l) return -1; return 0; } /* Negation */ -static int64 I64_neg(int64 x) +static int64_t I64_neg(int64_t x) { - int64 res; + int64_t res; res.l = -x.l; res.h = ~x.h; if (res.l == 0) res.h++; @@ -60,9 +60,9 @@ static int64 I64_neg(int64 x) } /* Addition */ -static int64 I64_add(int64 x, int64 y) +static int64_t I64_add(int64_t x, int64_t y) { - int64 res; + int64_t res; res.l = x.l + y.l; res.h = x.h + y.h; if (res.l < x.l) res.h++; @@ -70,9 +70,9 @@ static int64 I64_add(int64 x, int64 y) } /* Subtraction */ -static int64 I64_sub(int64 x, int64 y) +static int64_t I64_sub(int64_t x, int64_t y) { - int64 res; + int64_t res; res.l = x.l - y.l; res.h = x.h - y.h; if (x.l < y.l) res.h--; @@ -80,13 +80,13 @@ static int64 I64_sub(int64 x, int64 y) } /* Multiplication */ -static int64 I64_mul(int64 x, int64 y) +static int64_t I64_mul(int64_t x, int64_t y) { - int64 res; - uint32 prod00 = (x.l & 0xFFFF) * (y.l & 0xFFFF); - uint32 prod10 = (x.l >> 16) * (y.l & 0xFFFF); - uint32 prod01 = (x.l & 0xFFFF) * (y.l >> 16); - uint32 prod11 = (x.l >> 16) * (y.l >> 16); + int64_t res; + uint32_t prod00 = (x.l & 0xFFFF) * (y.l & 0xFFFF); + uint32_t prod10 = (x.l >> 16) * (y.l & 0xFFFF); + uint32_t prod01 = (x.l & 0xFFFF) * (y.l >> 16); + uint32_t prod11 = (x.l >> 16) * (y.l >> 16); res.l = prod00; res.h = prod11 + (prod01 >> 16) + (prod10 >> 16); prod01 = prod01 << 16; res.l += prod01; if (res.l < prod01) res.h++; @@ -96,39 +96,39 @@ static int64 I64_mul(int64 x, int64 y) } #define I64_is_zero(x) (((x).l | (x).h) == 0) -#define I64_is_negative(x) ((int32) (x).h < 0) +#define I64_is_negative(x) ((int32_t) (x).h < 0) #define I64_is_min_int(x) ((x).l == 0 && (x).h == 0x80000000U) #define I64_is_minus_one(x) (((x).l & (x).h) == 0xFFFFFFFFU) /* Bitwise operations */ -static int64 I64_and(int64 x, int64 y) +static int64_t I64_and(int64_t x, int64_t y) { - int64 res; + int64_t res; res.l = x.l & y.l; res.h = x.h & y.h; return res; } -static int64 I64_or(int64 x, int64 y) +static int64_t I64_or(int64_t x, int64_t y) { - int64 res; + int64_t res; res.l = x.l | y.l; res.h = x.h | y.h; return res; } -static int64 I64_xor(int64 x, int64 y) +static int64_t I64_xor(int64_t x, int64_t y) { - int64 res; + int64_t res; res.l = x.l ^ y.l; res.h = x.h ^ y.h; return res; } /* Shifts */ -static int64 I64_lsl(int64 x, int s) +static int64_t I64_lsl(int64_t x, int s) { - int64 res; + int64_t res; s = s & 63; if (s == 0) return x; if (s < 32) { @@ -141,9 +141,9 @@ static int64 I64_lsl(int64 x, int s) return res; } -static int64 I64_lsr(int64 x, int s) +static int64_t I64_lsr(int64_t x, int s) { - int64 res; + int64_t res; s = s & 63; if (s == 0) return x; if (s < 32) { @@ -156,17 +156,17 @@ static int64 I64_lsr(int64 x, int s) return res; } -static int64 I64_asr(int64 x, int s) +static int64_t I64_asr(int64_t x, int s) { - int64 res; + int64_t res; s = s & 63; if (s == 0) return x; if (s < 32) { res.l = (x.l >> s) | (x.h << (32 - s)); - res.h = (int32) x.h >> s; + res.h = (int32_t) x.h >> s; } else { - res.l = (int32) x.h >> (s - 32); - res.h = (int32) x.h >> 31; + res.l = (int32_t) x.h >> (s - 32); + res.h = (int32_t) x.h >> 31; } return res; } @@ -176,15 +176,15 @@ static int64 I64_asr(int64 x, int s) #define I64_SHL1(x) x.h = (x.h << 1) | (x.l >> 31); x.l <<= 1 #define I64_SHR1(x) x.l = (x.l >> 1) | (x.h << 31); x.h >>= 1 -static void I64_udivmod(uint64 modulus, uint64 divisor, - uint64 * quo, uint64 * mod) +static void I64_udivmod(uint64_t modulus, uint64_t divisor, + uint64_t * quo, uint64_t * mod) { - int64 quotient, mask; + int64_t quotient, mask; int cmp; quotient.h = 0; quotient.l = 0; mask.h = 0; mask.l = 1; - while ((int32) divisor.h >= 0) { + while ((int32_t) divisor.h >= 0) { cmp = I64_ucompare(divisor, modulus); I64_SHL1(divisor); I64_SHL1(mask); @@ -202,27 +202,27 @@ static void I64_udivmod(uint64 modulus, uint64 divisor, *mod = modulus; } -static int64 I64_div(int64 x, int64 y) +static int64_t I64_div(int64_t x, int64_t y) { - int64 q, r; - int32 sign; + int64_t q, r; + int32_t sign; sign = x.h ^ y.h; - if ((int32) x.h < 0) x = I64_neg(x); - if ((int32) y.h < 0) y = I64_neg(y); + if ((int32_t) x.h < 0) x = I64_neg(x); + if ((int32_t) y.h < 0) y = I64_neg(y); I64_udivmod(x, y, &q, &r); if (sign < 0) q = I64_neg(q); return q; } -static int64 I64_mod(int64 x, int64 y) +static int64_t I64_mod(int64_t x, int64_t y) { - int64 q, r; - int32 sign; + int64_t q, r; + int32_t sign; sign = x.h; - if ((int32) x.h < 0) x = I64_neg(x); - if ((int32) y.h < 0) y = I64_neg(y); + if ((int32_t) x.h < 0) x = I64_neg(x); + if ((int32_t) y.h < 0) y = I64_neg(y); I64_udivmod(x, y, &q, &r); if (sign < 0) r = I64_neg(r); return r; @@ -230,49 +230,49 @@ static int64 I64_mod(int64 x, int64 y) /* Coercions */ -static int64 I64_of_int32(int32 x) +static int64_t I64_of_int32(int32_t x) { - int64 res; + int64_t res; res.l = x; res.h = x >> 31; return res; } -#define I64_to_int32(x) ((int32) (x).l) +#define I64_to_int32(x) ((int32_t) (x).l) /* Note: we assume sizeof(intnat) = 4 here, which is true otherwise autoconfiguration would have selected native 64-bit integers */ #define I64_of_intnat I64_of_int32 #define I64_to_intnat I64_to_int32 -static double I64_to_double(int64 x) +static double I64_to_double(int64_t x) { double res; - int32 sign = x.h; + int32_t sign = x.h; if (sign < 0) x = I64_neg(x); res = ldexp((double) x.h, 32) + x.l; if (sign < 0) res = -res; return res; } -static int64 I64_of_double(double f) +static int64_t I64_of_double(double f) { - int64 res; + int64_t res; double frac, integ; int neg; neg = (f < 0); f = fabs(f); frac = modf(ldexp(f, -32), &integ); - res.h = (uint32) integ; - res.l = (uint32) ldexp(frac, 32); + res.h = (uint32_t) integ; + res.l = (uint32_t) ldexp(frac, 32); if (neg) res = I64_neg(res); return res; } -static int64 I64_bswap(int64 x) +static int64_t I64_bswap(int64_t x) { - int64 res; + int64_t res; res.h = (((x.l & 0x000000FF) << 24) | ((x.l & 0x0000FF00) << 8) | ((x.l & 0x00FF0000) >> 8) | diff --git a/byterun/int64_format.h b/byterun/int64_format.h index b0de527204..aa8f1abab5 100644 --- a/byterun/int64_format.h +++ b/byterun/int64_format.h @@ -17,7 +17,7 @@ #ifndef CAML_INT64_FORMAT_H #define CAML_INT64_FORMAT_H -static void I64_format(char * buffer, char * fmt, int64 x) +static void I64_format(char * buffer, char * fmt, int64_t x) { static char conv_lower[] = "0123456789abcdef"; static char conv_upper[] = "0123456789ABCDEF"; @@ -26,7 +26,7 @@ static void I64_format(char * buffer, char * fmt, int64 x) int base, width, sign, i, rawlen; char * cvtbl; char * p, * r; - int64 wbase, digit; + int64_t wbase, digit; /* Parsing of format */ justify = '+'; diff --git a/byterun/int64_native.h b/byterun/int64_native.h index e9ffe67495..b6716ada2a 100644 --- a/byterun/int64_native.h +++ b/byterun/int64_native.h @@ -18,36 +18,36 @@ #ifndef CAML_INT64_NATIVE_H #define CAML_INT64_NATIVE_H -#define I64_literal(hi,lo) ((int64)(hi) << 32 | (lo)) -#define I64_split(x,hi,lo) (hi = (uint32)((x)>>32), lo = (uint32)(x)) +#define I64_literal(hi,lo) ((int64_t)(hi) << 32 | (lo)) +#define I64_split(x,hi,lo) (hi = (uint32_t)((x)>>32), lo = (uint32_t)(x)) #define I64_compare(x,y) (((x) > (y)) - ((x) < (y))) -#define I64_ult(x,y) ((uint64)(x) < (uint64)(y)) +#define I64_ult(x,y) ((uint64_t)(x) < (uint64_t)(y)) #define I64_neg(x) (-(x)) #define I64_add(x,y) ((x) + (y)) #define I64_sub(x,y) ((x) - (y)) #define I64_mul(x,y) ((x) * (y)) #define I64_is_zero(x) ((x) == 0) #define I64_is_negative(x) ((x) < 0) -#define I64_is_min_int(x) ((x) == ((int64)1 << 63)) +#define I64_is_min_int(x) ((x) == ((int64_t)1 << 63)) #define I64_is_minus_one(x) ((x) == -1) #define I64_div(x,y) ((x) / (y)) #define I64_mod(x,y) ((x) % (y)) #define I64_udivmod(x,y,quo,rem) \ - (*(rem) = (uint64)(x) % (uint64)(y), \ - *(quo) = (uint64)(x) / (uint64)(y)) + (*(rem) = (uint64_t)(x) % (uint64_t)(y), \ + *(quo) = (uint64_t)(x) / (uint64_t)(y)) #define I64_and(x,y) ((x) & (y)) #define I64_or(x,y) ((x) | (y)) #define I64_xor(x,y) ((x) ^ (y)) #define I64_lsl(x,y) ((x) << (y)) #define I64_asr(x,y) ((x) >> (y)) -#define I64_lsr(x,y) ((uint64)(x) >> (y)) +#define I64_lsr(x,y) ((uint64_t)(x) >> (y)) #define I64_to_intnat(x) ((intnat) (x)) #define I64_of_intnat(x) ((intnat) (x)) -#define I64_to_int32(x) ((int32) (x)) -#define I64_of_int32(x) ((int64) (x)) +#define I64_to_int32(x) ((int32_t) (x)) +#define I64_of_int32(x) ((int64_t) (x)) #define I64_to_double(x) ((double)(x)) -#define I64_of_double(x) ((int64)(x)) +#define I64_of_double(x) ((int64_t)(x)) #define I64_bswap(x) ((((x) & 0x00000000000000FFULL) << 56) | \ (((x) & 0x000000000000FF00ULL) << 40) | \ diff --git a/byterun/intern.c b/byterun/intern.c index e353e6b7b6..638ff7287a 100644 --- a/byterun/intern.c +++ b/byterun/intern.c @@ -553,7 +553,7 @@ static void intern_add_to_heap(mlsize_t whsize) value caml_input_val(struct channel *chan) { - uint32 magic; + uint32_t magic; mlsize_t block_len, num_objects, whsize; char * block; value res; @@ -663,7 +663,7 @@ static value input_val_from_block(void) CAMLexport value caml_input_value_from_malloc(char * data, intnat ofs) { - uint32 magic; + uint32_t magic; value obj; intern_input = (unsigned char *) data; @@ -681,7 +681,7 @@ CAMLexport value caml_input_value_from_malloc(char * data, intnat ofs) CAMLexport value caml_input_value_from_block(char * data, intnat len) { - uint32 magic; + uint32_t magic; mlsize_t block_len; value obj; @@ -700,7 +700,7 @@ CAMLexport value caml_input_value_from_block(char * data, intnat len) CAMLprim value caml_marshal_data_size(value buff, value ofs) { - uint32 magic; + uint32_t magic; mlsize_t block_len; intern_src = &Byte_u(buff, Long_val(ofs)); @@ -738,7 +738,7 @@ static char * intern_resolve_code_pointer(unsigned char digest[16], static void intern_bad_code_pointer(unsigned char digest[16]) { char msg[256]; - snprintf(msg, sizeof(msg), + snprintf(msg, sizeof(msg), "input_value: unknown code module " "%02X%02X%02X%02X%02X%02X%02X%02X" "%02X%02X%02X%02X%02X%02X%02X%02X", @@ -771,26 +771,26 @@ CAMLexport int caml_deserialize_sint_2(void) return read16s(); } -CAMLexport uint32 caml_deserialize_uint_4(void) +CAMLexport uint32_t caml_deserialize_uint_4(void) { return read32u(); } -CAMLexport int32 caml_deserialize_sint_4(void) +CAMLexport int32_t caml_deserialize_sint_4(void) { return read32s(); } -CAMLexport uint64 caml_deserialize_uint_8(void) +CAMLexport uint64_t caml_deserialize_uint_8(void) { - uint64 i; + uint64_t i; caml_deserialize_block_8(&i, 1); return i; } -CAMLexport int64 caml_deserialize_sint_8(void) +CAMLexport int64_t caml_deserialize_sint_8(void) { - int64 i; + int64_t i; caml_deserialize_block_8(&i, 1); return i; } diff --git a/byterun/interp.c b/byterun/interp.c index 9b682ba6ea..e22b28b8bd 100644 --- a/byterun/interp.c +++ b/byterun/interp.c @@ -793,7 +793,7 @@ value caml_interprete(code_t prog, asize_t prog_size) if (accu == Val_false) pc += *pc; else pc++; Next; Instruct(SWITCH): { - uint32 sizes = *pc++; + uint32_t sizes = *pc++; if (Is_block(accu)) { intnat index = Tag_val(accu); Assert ((uintnat) index < (sizes >> 16)); diff --git a/byterun/intext.h b/byterun/intext.h index f7aa655c9f..2c108a4ae0 100644 --- a/byterun/intext.h +++ b/byterun/intext.h @@ -119,8 +119,8 @@ CAMLextern value caml_input_value_from_block(char * data, intnat len); CAMLextern void caml_serialize_int_1(int i); CAMLextern void caml_serialize_int_2(int i); -CAMLextern void caml_serialize_int_4(int32 i); -CAMLextern void caml_serialize_int_8(int64 i); +CAMLextern void caml_serialize_int_4(int32_t i); +CAMLextern void caml_serialize_int_8(int64_t i); CAMLextern void caml_serialize_float_4(float f); CAMLextern void caml_serialize_float_8(double f); CAMLextern void caml_serialize_block_1(void * data, intnat len); @@ -133,10 +133,10 @@ CAMLextern int caml_deserialize_uint_1(void); CAMLextern int caml_deserialize_sint_1(void); CAMLextern int caml_deserialize_uint_2(void); CAMLextern int caml_deserialize_sint_2(void); -CAMLextern uint32 caml_deserialize_uint_4(void); -CAMLextern int32 caml_deserialize_sint_4(void); -CAMLextern uint64 caml_deserialize_uint_8(void); -CAMLextern int64 caml_deserialize_sint_8(void); +CAMLextern uint32_t caml_deserialize_uint_4(void); +CAMLextern int32_t caml_deserialize_sint_4(void); +CAMLextern uint64_t caml_deserialize_uint_8(void); +CAMLextern int64_t caml_deserialize_sint_8(void); CAMLextern float caml_deserialize_float_4(void); CAMLextern double caml_deserialize_float_8(void); CAMLextern void caml_deserialize_block_1(void * data, intnat len); diff --git a/byterun/ints.c b/byterun/ints.c index a5e6e2e6d7..056e82aa37 100644 --- a/byterun/ints.c +++ b/byterun/ints.c @@ -172,8 +172,8 @@ CAMLprim value caml_format_int(value fmt, value arg) static int int32_cmp(value v1, value v2) { - int32 i1 = Int32_val(v1); - int32 i2 = Int32_val(v2); + int32_t i1 = Int32_val(v1); + int32_t i2 = Int32_val(v2); return (i1 > i2) - (i1 < i2); } @@ -191,7 +191,7 @@ static void int32_serialize(value v, uintnat * wsize_32, static uintnat int32_deserialize(void * dst) { - *((int32 *) dst) = caml_deserialize_sint_4(); + *((int32_t *) dst) = caml_deserialize_sint_4(); return 4; } @@ -205,7 +205,7 @@ CAMLexport struct custom_operations caml_int32_ops = { custom_compare_ext_default }; -CAMLexport value caml_copy_int32(int32 i) +CAMLexport value caml_copy_int32(int32_t i) { value res = caml_alloc_custom(&caml_int32_ops, 4, 0, 1); Int32_val(res) = i; @@ -226,8 +226,8 @@ CAMLprim value caml_int32_mul(value v1, value v2) CAMLprim value caml_int32_div(value v1, value v2) { - int32 dividend = Int32_val(v1); - int32 divisor = Int32_val(v2); + int32_t dividend = Int32_val(v1); + int32_t divisor = Int32_val(v2); if (divisor == 0) caml_raise_zero_divide(); /* PR#4740: on some processors, division crashes on overflow. Implement the same behavior as for type "int". */ @@ -237,8 +237,8 @@ CAMLprim value caml_int32_div(value v1, value v2) CAMLprim value caml_int32_mod(value v1, value v2) { - int32 dividend = Int32_val(v1); - int32 divisor = Int32_val(v2); + int32_t dividend = Int32_val(v1); + int32_t divisor = Int32_val(v2); if (divisor == 0) caml_raise_zero_divide(); /* PR#4740: on some processors, modulus crashes if division overflows. Implement the same behavior as for type "int". */ @@ -262,9 +262,9 @@ CAMLprim value caml_int32_shift_right(value v1, value v2) { return caml_copy_int32(Int32_val(v1) >> Int_val(v2)); } CAMLprim value caml_int32_shift_right_unsigned(value v1, value v2) -{ return caml_copy_int32((uint32)Int32_val(v1) >> Int_val(v2)); } +{ return caml_copy_int32((uint32_t)Int32_val(v1) >> Int_val(v2)); } -static int32 caml_swap32(int32 x) +static int32_t caml_swap32(int32_t x) { return (((x & 0x000000FF) << 24) | ((x & 0x0000FF00) << 8) | @@ -285,15 +285,15 @@ CAMLprim value caml_int32_to_int(value v) { return Val_long(Int32_val(v)); } CAMLprim value caml_int32_of_float(value v) -{ return caml_copy_int32((int32)(Double_val(v))); } +{ return caml_copy_int32((int32_t)(Double_val(v))); } CAMLprim value caml_int32_to_float(value v) { return caml_copy_double((double)(Int32_val(v))); } CAMLprim value caml_int32_compare(value v1, value v2) { - int32 i1 = Int32_val(v1); - int32 i2 = Int32_val(v2); + int32_t i1 = Int32_val(v1); + int32_t i2 = Int32_val(v2); int res = (i1 > i2) - (i1 < i2); return Val_int(res); } @@ -313,14 +313,14 @@ CAMLprim value caml_int32_of_string(value s) CAMLprim value caml_int32_bits_of_float(value vd) { - union { float d; int32 i; } u; + union { float d; int32_t i; } u; u.d = Double_val(vd); return caml_copy_int32(u.i); } CAMLprim value caml_int32_float_of_bits(value vi) { - union { float d; int32 i; } u; + union { float d; int32_t i; } u; u.i = Int32_val(vi); return caml_copy_double(u.d); } @@ -329,11 +329,11 @@ CAMLprim value caml_int32_float_of_bits(value vi) #ifdef ARCH_ALIGN_INT64 -CAMLexport int64 caml_Int64_val(value v) +CAMLexport int64_t caml_Int64_val(value v) { - union { int32 i[2]; int64 j; } buffer; - buffer.i[0] = ((int32 *) Data_custom_val(v))[0]; - buffer.i[1] = ((int32 *) Data_custom_val(v))[1]; + union { int32_t i[2]; int64_t j; } buffer; + buffer.i[0] = ((int32_t *) Data_custom_val(v))[0]; + buffer.i[1] = ((int32_t *) Data_custom_val(v))[1]; return buffer.j; } @@ -341,15 +341,15 @@ CAMLexport int64 caml_Int64_val(value v) static int int64_cmp(value v1, value v2) { - int64 i1 = Int64_val(v1); - int64 i2 = Int64_val(v2); + int64_t i1 = Int64_val(v1); + int64_t i2 = Int64_val(v2); return (i1 > i2) - (i1 < i2); } static intnat int64_hash(value v) { - int64 x = Int64_val(v); - uint32 lo = (uint32) x, hi = (uint32) (x >> 32); + int64_t x = Int64_val(v); + uint32_t lo = (uint32_t) x, hi = (uint32_t) (x >> 32); return hi ^ lo; } @@ -363,12 +363,12 @@ static void int64_serialize(value v, uintnat * wsize_32, static uintnat int64_deserialize(void * dst) { #ifndef ARCH_ALIGN_INT64 - *((int64 *) dst) = caml_deserialize_sint_8(); + *((int64_t *) dst) = caml_deserialize_sint_8(); #else - union { int32 i[2]; int64 j; } buffer; + union { int32_t i[2]; int64_t j; } buffer; buffer.j = caml_deserialize_sint_8(); - ((int32 *) dst)[0] = buffer.i[0]; - ((int32 *) dst)[1] = buffer.i[1]; + ((int32_t *) dst)[0] = buffer.i[0]; + ((int32_t *) dst)[1] = buffer.i[1]; #endif return 8; } @@ -383,16 +383,16 @@ CAMLexport struct custom_operations caml_int64_ops = { custom_compare_ext_default }; -CAMLexport value caml_copy_int64(int64 i) +CAMLexport value caml_copy_int64(int64_t i) { value res = caml_alloc_custom(&caml_int64_ops, 8, 0, 1); #ifndef ARCH_ALIGN_INT64 Int64_val(res) = i; #else - union { int32 i[2]; int64 j; } buffer; + union { int32_t i[2]; int64_t j; } buffer; buffer.j = i; - ((int32 *) Data_custom_val(res))[0] = buffer.i[0]; - ((int32 *) Data_custom_val(res))[1] = buffer.i[1]; + ((int32_t *) Data_custom_val(res))[0] = buffer.i[0]; + ((int32_t *) Data_custom_val(res))[1] = buffer.i[1]; #endif return res; } @@ -413,23 +413,23 @@ CAMLprim value caml_int64_mul(value v1, value v2) CAMLprim value caml_int64_div(value v1, value v2) { - int64 dividend = Int64_val(v1); - int64 divisor = Int64_val(v2); + int64_t dividend = Int64_val(v1); + int64_t divisor = Int64_val(v2); if (divisor == 0) caml_raise_zero_divide(); /* PR#4740: on some processors, division crashes on overflow. Implement the same behavior as for type "int". */ - if (dividend == ((int64)1 << 63) && divisor == -1) return v1; + if (dividend == ((int64_t)1 << 63) && divisor == -1) return v1; return caml_copy_int64(Int64_val(v1) / divisor); } CAMLprim value caml_int64_mod(value v1, value v2) { - int64 dividend = Int64_val(v1); - int64 divisor = Int64_val(v2); + int64_t dividend = Int64_val(v1); + int64_t divisor = Int64_val(v2); if (divisor == 0) caml_raise_zero_divide(); /* PR#4740: on some processors, division crashes on overflow. Implement the same behavior as for type "int". */ - if (dividend == ((int64)1 << 63) && divisor == -1) return caml_copy_int64(0); + if (dividend == ((int64_t)1 << 63) && divisor == -1) return caml_copy_int64(0); return caml_copy_int64(Int64_val(v1) % divisor); } @@ -449,7 +449,7 @@ CAMLprim value caml_int64_shift_right(value v1, value v2) { return caml_copy_int64(Int64_val(v1) >> Int_val(v2)); } CAMLprim value caml_int64_shift_right_unsigned(value v1, value v2) -{ return caml_copy_int64((uint64) (Int64_val(v1)) >> Int_val(v2)); } +{ return caml_copy_int64((uint64_t) (Int64_val(v1)) >> Int_val(v2)); } #ifdef ARCH_SIXTYFOUR static value caml_swap64(value x) @@ -470,7 +470,7 @@ value caml_int64_direct_bswap(value v) CAMLprim value caml_int64_bswap(value v) { - int64 x = Int64_val(v); + int64_t x = Int64_val(v); return caml_copy_int64 (((x & 0x00000000000000FFULL) << 56) | ((x & 0x000000000000FF00ULL) << 40) | @@ -479,37 +479,37 @@ CAMLprim value caml_int64_bswap(value v) ((x & 0x000000FF00000000ULL) >> 8) | ((x & 0x0000FF0000000000ULL) >> 24) | ((x & 0x00FF000000000000ULL) >> 40) | - ((x & 0xFF00000000000000ULL) >> 56)); + ((x & 0xFF00000000000000ULL) >> 56)); } CAMLprim value caml_int64_of_int(value v) -{ return caml_copy_int64((int64) (Long_val(v))); } +{ return caml_copy_int64((int64_t) (Long_val(v))); } CAMLprim value caml_int64_to_int(value v) { return Val_long((intnat) (Int64_val(v))); } CAMLprim value caml_int64_of_float(value v) -{ return caml_copy_int64((int64) (Double_val(v))); } +{ return caml_copy_int64((int64_t) (Double_val(v))); } CAMLprim value caml_int64_to_float(value v) { return caml_copy_double((double) (Int64_val(v))); } CAMLprim value caml_int64_of_int32(value v) -{ return caml_copy_int64((int64) (Int32_val(v))); } +{ return caml_copy_int64((int64_t) (Int32_val(v))); } CAMLprim value caml_int64_to_int32(value v) -{ return caml_copy_int32((int32) (Int64_val(v))); } +{ return caml_copy_int32((int32_t) (Int64_val(v))); } CAMLprim value caml_int64_of_nativeint(value v) -{ return caml_copy_int64((int64) (Nativeint_val(v))); } +{ return caml_copy_int64((int64_t) (Nativeint_val(v))); } CAMLprim value caml_int64_to_nativeint(value v) { return caml_copy_nativeint((intnat) (Int64_val(v))); } CAMLprim value caml_int64_compare(value v1, value v2) { - int64 i1 = Int64_val(v1); - int64 i2 = Int64_val(v2); + int64_t i1 = Int64_val(v1); + int64_t i2 = Int64_val(v2); return Val_int((i1 > i2) - (i1 < i2)); } @@ -524,11 +524,11 @@ CAMLprim value caml_int64_format(value fmt, value arg) CAMLprim value caml_int64_of_string(value s) { char * p; - uint64 res, threshold; + uint64_t res, threshold; int sign, base, d; p = parse_sign_and_base(String_val(s), &base, &sign); - threshold = ((uint64) -1) / base; + threshold = ((uint64_t) -1) / base; d = parse_digit(*p); if (d < 0 || d >= base) caml_failwith("int_of_string"); res = d; @@ -541,7 +541,7 @@ CAMLprim value caml_int64_of_string(value s) if (res > threshold) caml_failwith("int_of_string"); res = base * res + d; /* Detect overflow in addition (base * res) + d */ - if (res < (uint64) d) caml_failwith("int_of_string"); + if (res < (uint64_t) d) caml_failwith("int_of_string"); } if (p != String_val(s) + caml_string_length(s)){ caml_failwith("int_of_string"); @@ -549,9 +549,9 @@ CAMLprim value caml_int64_of_string(value s) if (base == 10) { /* Signed representation expected, allow -2^63 to 2^63 - 1 only */ if (sign >= 0) { - if (res >= (uint64)1 << 63) caml_failwith("int_of_string"); + if (res >= (uint64_t)1 << 63) caml_failwith("int_of_string"); } else { - if (res > (uint64)1 << 63) caml_failwith("int_of_string"); + if (res > (uint64_t)1 << 63) caml_failwith("int_of_string"); } } if (sign < 0) res = - res; @@ -560,20 +560,20 @@ CAMLprim value caml_int64_of_string(value s) CAMLprim value caml_int64_bits_of_float(value vd) { - union { double d; int64 i; int32 h[2]; } u; + union { double d; int64_t i; int32_t h[2]; } u; u.d = Double_val(vd); #if defined(__arm__) && !defined(__ARM_EABI__) - { int32 t = u.h[0]; u.h[0] = u.h[1]; u.h[1] = t; } + { int32_t t = u.h[0]; u.h[0] = u.h[1]; u.h[1] = t; } #endif return caml_copy_int64(u.i); } CAMLprim value caml_int64_float_of_bits(value vi) { - union { double d; int64 i; int32 h[2]; } u; + union { double d; int64_t i; int32_t h[2]; } u; u.i = Int64_val(vi); #if defined(__arm__) && !defined(__ARM_EABI__) - { int32 t = u.h[0]; u.h[0] = u.h[1]; u.h[1] = t; } + { int32_t t = u.h[0]; u.h[0] = u.h[1]; u.h[1] = t; } #endif return caml_copy_double(u.d); } @@ -606,7 +606,7 @@ static void nativeint_serialize(value v, uintnat * wsize_32, #ifdef ARCH_SIXTYFOUR if (l >= -((intnat)1 << 31) && l < ((intnat)1 << 31)) { caml_serialize_int_1(1); - caml_serialize_int_4((int32) l); + caml_serialize_int_4((int32_t) l); } else { caml_serialize_int_1(2); caml_serialize_int_8(l); diff --git a/byterun/io.c b/byterun/io.c index 5f04a966e6..bedc0f03ad 100644 --- a/byterun/io.c +++ b/byterun/io.c @@ -207,7 +207,7 @@ CAMLexport void caml_flush(struct channel *channel) /* Output data */ -CAMLexport void caml_putword(struct channel *channel, uint32 w) +CAMLexport void caml_putword(struct channel *channel, uint32_t w) { if (! caml_channel_binary_mode(channel)) caml_failwith("output_binary_int: not a binary channel"); @@ -303,10 +303,10 @@ CAMLexport unsigned char caml_refill(struct channel *channel) return (unsigned char)(channel->buff[0]); } -CAMLexport uint32 caml_getword(struct channel *channel) +CAMLexport uint32_t caml_getword(struct channel *channel) { int i; - uint32 res; + uint32_t res; if (! caml_channel_binary_mode(channel)) caml_failwith("input_binary_int: not a binary channel"); diff --git a/byterun/io.h b/byterun/io.h index 64a8bf50ae..5a9c0374c3 100644 --- a/byterun/io.h +++ b/byterun/io.h @@ -78,12 +78,12 @@ CAMLextern value caml_alloc_channel(struct channel *chan); CAMLextern int caml_flush_partial (struct channel *); CAMLextern void caml_flush (struct channel *); -CAMLextern void caml_putword (struct channel *, uint32); +CAMLextern void caml_putword (struct channel *, uint32_t); CAMLextern int caml_putblock (struct channel *, char *, intnat); CAMLextern void caml_really_putblock (struct channel *, char *, intnat); CAMLextern unsigned char caml_refill (struct channel *); -CAMLextern uint32 caml_getword (struct channel *); +CAMLextern uint32_t caml_getword (struct channel *); CAMLextern int caml_getblock (struct channel *, char *, intnat); CAMLextern int caml_really_getblock (struct channel *, char *, intnat); @@ -107,7 +107,7 @@ CAMLextern struct channel * caml_all_opened_channels; #define Unlock_exn() \ if (caml_channel_mutex_unlock_exn != NULL) (*caml_channel_mutex_unlock_exn)() -/* Conversion between file_offset and int64 */ +/* Conversion between file_offset and int64_t */ #define Val_file_offset(fofs) caml_copy_int64(fofs) #define File_offset_val(v) ((file_offset) Int64_val(v)) diff --git a/byterun/md5.c b/byterun/md5.c index 10ac76abc3..2dc90a2040 100644 --- a/byterun/md5.c +++ b/byterun/md5.c @@ -97,11 +97,11 @@ CAMLexport void caml_md5_block(unsigned char digest[16], #else static void byteReverse(unsigned char * buf, unsigned longs) { - uint32 t; + uint32_t t; do { - t = (uint32) ((unsigned) buf[3] << 8 | buf[2]) << 16 | + t = (uint32_t) ((unsigned) buf[3] << 8 | buf[2]) << 16 | ((unsigned) buf[1] << 8 | buf[0]); - *(uint32 *) buf = t; + *(uint32_t *) buf = t; buf += 4; } while (--longs); } @@ -129,12 +129,12 @@ CAMLexport void caml_MD5Init(struct MD5Context *ctx) CAMLexport void caml_MD5Update(struct MD5Context *ctx, unsigned char *buf, uintnat len) { - uint32 t; + uint32_t t; /* Update bitcount */ t = ctx->bits[0]; - if ((ctx->bits[0] = t + ((uint32) len << 3)) < t) + if ((ctx->bits[0] = t + ((uint32_t) len << 3)) < t) ctx->bits[1]++; /* Carry from low to high */ ctx->bits[1] += len >> 29; @@ -152,7 +152,7 @@ CAMLexport void caml_MD5Update(struct MD5Context *ctx, unsigned char *buf, } memcpy(p, buf, t); byteReverse(ctx->in, 16); - caml_MD5Transform(ctx->buf, (uint32 *) ctx->in); + caml_MD5Transform(ctx->buf, (uint32_t *) ctx->in); buf += t; len -= t; } @@ -161,7 +161,7 @@ CAMLexport void caml_MD5Update(struct MD5Context *ctx, unsigned char *buf, while (len >= 64) { memcpy(ctx->in, buf, 64); byteReverse(ctx->in, 16); - caml_MD5Transform(ctx->buf, (uint32 *) ctx->in); + caml_MD5Transform(ctx->buf, (uint32_t *) ctx->in); buf += 64; len -= 64; } @@ -196,7 +196,7 @@ CAMLexport void caml_MD5Final(unsigned char *digest, struct MD5Context *ctx) /* Two lots of padding: Pad the first block to 64 bytes */ memset(p, 0, count); byteReverse(ctx->in, 16); - caml_MD5Transform(ctx->buf, (uint32 *) ctx->in); + caml_MD5Transform(ctx->buf, (uint32_t *) ctx->in); /* Now fill the next block with 56 bytes */ memset(ctx->in, 0, 56); @@ -207,10 +207,10 @@ CAMLexport void caml_MD5Final(unsigned char *digest, struct MD5Context *ctx) byteReverse(ctx->in, 14); /* Append length in bits and transform */ - ((uint32 *) ctx->in)[14] = ctx->bits[0]; - ((uint32 *) ctx->in)[15] = ctx->bits[1]; + ((uint32_t *) ctx->in)[14] = ctx->bits[0]; + ((uint32_t *) ctx->in)[15] = ctx->bits[1]; - caml_MD5Transform(ctx->buf, (uint32 *) ctx->in); + caml_MD5Transform(ctx->buf, (uint32_t *) ctx->in); byteReverse((unsigned char *) ctx->buf, 4); memcpy(digest, ctx->buf, 16); memset(ctx, 0, sizeof(*ctx)); /* In case it's sensitive */ @@ -233,9 +233,9 @@ CAMLexport void caml_MD5Final(unsigned char *digest, struct MD5Context *ctx) * reflect the addition of 16 longwords of new data. caml_MD5Update blocks * the data and converts bytes into longwords for this routine. */ -CAMLexport void caml_MD5Transform(uint32 *buf, uint32 *in) +CAMLexport void caml_MD5Transform(uint32_t *buf, uint32_t *in) { - register uint32 a, b, c, d; + register uint32_t a, b, c, d; a = buf[0]; b = buf[1]; diff --git a/byterun/md5.h b/byterun/md5.h index d8aff097af..f63667d56a 100644 --- a/byterun/md5.h +++ b/byterun/md5.h @@ -26,8 +26,8 @@ CAMLextern void caml_md5_block(unsigned char digest[16], void * data, uintnat len); struct MD5Context { - uint32 buf[4]; - uint32 bits[2]; + uint32_t buf[4]; + uint32_t bits[2]; unsigned char in[64]; }; @@ -35,7 +35,7 @@ CAMLextern void caml_MD5Init (struct MD5Context *context); CAMLextern void caml_MD5Update (struct MD5Context *context, unsigned char *buf, uintnat len); CAMLextern void caml_MD5Final (unsigned char *digest, struct MD5Context *ctx); -CAMLextern void caml_MD5Transform (uint32 *buf, uint32 *in); +CAMLextern void caml_MD5Transform (uint32_t *buf, uint32_t *in); #endif /* CAML_MD5_H */ diff --git a/byterun/mlvalues.h b/byterun/mlvalues.h index 268bcfe9ff..a08948eb1b 100644 --- a/byterun/mlvalues.h +++ b/byterun/mlvalues.h @@ -38,8 +38,8 @@ extern "C" { bp: Pointer to the first byte of a block. (a char *) op: Pointer to the first field of a block. (a value *) hp: Pointer to the header of a block. (a char *) - int32: Four bytes on all architectures. - int64: Eight bytes on all architectures. + int32_t: Four bytes on all architectures. + int64_t: Eight bytes on all architectures. Remark: A block size is always a multiple of the word size, and at least one word plus the header. @@ -161,7 +161,7 @@ bits 63 10 9 8 7 0 /* Fields are numbered from 0. */ #define Field(x, i) (((value *)(x)) [i]) /* Also an l-value. */ -typedef int32 opcode_t; +typedef int32_t opcode_t; typedef opcode_t * code_t; /* NOTE: [Forward_tag] and [Infix_tag] must be just under @@ -262,12 +262,12 @@ struct custom_operations; /* defined in [custom.h] */ /* Int32.t, Int64.t and Nativeint.t are represented as custom blocks. */ -#define Int32_val(v) (*((int32 *) Data_custom_val(v))) +#define Int32_val(v) (*((int32_t *) Data_custom_val(v))) #define Nativeint_val(v) (*((intnat *) Data_custom_val(v))) #ifndef ARCH_ALIGN_INT64 -#define Int64_val(v) (*((int64 *) Data_custom_val(v))) +#define Int64_val(v) (*((int64_t *) Data_custom_val(v))) #else -CAMLextern int64 caml_Int64_val(value v); +CAMLextern int64_t caml_Int64_val(value v); #define Int64_val(v) caml_Int64_val(v) #endif diff --git a/byterun/printexc.c b/byterun/printexc.c index 4f7b56b6ae..a371a71f69 100644 --- a/byterun/printexc.c +++ b/byterun/printexc.c @@ -131,7 +131,8 @@ void caml_fatal_uncaught_exception(value exn) { value *handle_uncaught_exception; - handle_uncaught_exception = caml_named_value("Printexc.handle_uncaught_exception"); + handle_uncaught_exception = + caml_named_value("Printexc.handle_uncaught_exception"); if (handle_uncaught_exception != NULL) /* [Printexc.handle_uncaught_exception] does not raise exception. */ caml_callback2(*handle_uncaught_exception, exn, Val_bool(DEBUGGER_IN_USE)); diff --git a/byterun/startup.c b/byterun/startup.c index 3697220664..ab926efe24 100644 --- a/byterun/startup.c +++ b/byterun/startup.c @@ -79,7 +79,7 @@ static void init_atoms(void) /* Read the trailer of a bytecode file */ -static void fixup_endianness_trailer(uint32 * p) +static void fixup_endianness_trailer(uint32_t * p) { #ifndef ARCH_BIG_ENDIAN Reverse_32(p, p); @@ -153,7 +153,7 @@ void caml_read_section_descriptors(int fd, struct exec_trailer *trail) Return the length of the section data in bytes, or -1 if no section found with that name. */ -int32 caml_seek_optional_section(int fd, struct exec_trailer *trail, char *name) +int32_t caml_seek_optional_section(int fd, struct exec_trailer *trail, char *name) { long ofs; int i; @@ -172,9 +172,9 @@ int32 caml_seek_optional_section(int fd, struct exec_trailer *trail, char *name) /* Position fd at the beginning of the section having the given name. Return the length of the section data in bytes. */ -int32 caml_seek_section(int fd, struct exec_trailer *trail, char *name) +int32_t caml_seek_section(int fd, struct exec_trailer *trail, char *name) { - int32 len = caml_seek_optional_section(fd, trail, name); + int32_t len = caml_seek_optional_section(fd, trail, name); if (len == -1) caml_fatal_error_arg("Fatal_error: section `%s' is missing\n", name); return len; @@ -185,7 +185,7 @@ int32 caml_seek_section(int fd, struct exec_trailer *trail, char *name) static char * read_section(int fd, struct exec_trailer *trail, char *name) { - int32 len; + int32_t len; char * data; len = caml_seek_optional_section(fd, trail, name); diff --git a/byterun/startup.h b/byterun/startup.h index 3dda64b336..3268d8875b 100644 --- a/byterun/startup.h +++ b/byterun/startup.h @@ -30,9 +30,9 @@ enum { FILE_NOT_FOUND = -1, BAD_BYTECODE = -2 }; extern int caml_attempt_open(char **name, struct exec_trailer *trail, int do_open_script); extern void caml_read_section_descriptors(int fd, struct exec_trailer *trail); -extern int32 caml_seek_optional_section(int fd, struct exec_trailer *trail, +extern int32_t caml_seek_optional_section(int fd, struct exec_trailer *trail, char *name); -extern int32 caml_seek_section(int fd, struct exec_trailer *trail, char *name); +extern int32_t caml_seek_section(int fd, struct exec_trailer *trail, char *name); #endif /* CAML_STARTUP_H */ diff --git a/byterun/str.c b/byterun/str.c index e2e0f4d266..9c7baa1b1d 100644 --- a/byterun/str.c +++ b/byterun/str.c @@ -101,7 +101,7 @@ CAMLprim value caml_string_get32(value str, value index) CAMLprim value caml_string_get64(value str, value index) { - uint64 res; + uint64_t res; unsigned char b1, b2, b3, b4, b5, b6, b7, b8; intnat idx = Long_val(index); if (idx < 0 || idx + 7 >= caml_string_length(str)) caml_array_bound_error(); @@ -114,15 +114,15 @@ CAMLprim value caml_string_get64(value str, value index) b7 = Byte_u(str, idx + 6); b8 = Byte_u(str, idx + 7); #ifdef ARCH_BIG_ENDIAN - res = (uint64) b1 << 56 | (uint64) b2 << 48 - | (uint64) b3 << 40 | (uint64) b4 << 32 - | (uint64) b5 << 24 | (uint64) b6 << 16 - | (uint64) b7 << 8 | (uint64) b8; + res = (uint64_t) b1 << 56 | (uint64_t) b2 << 48 + | (uint64_t) b3 << 40 | (uint64_t) b4 << 32 + | (uint64_t) b5 << 24 | (uint64_t) b6 << 16 + | (uint64_t) b7 << 8 | (uint64_t) b8; #else - res = (uint64) b8 << 56 | (uint64) b7 << 48 - | (uint64) b6 << 40 | (uint64) b5 << 32 - | (uint64) b4 << 24 | (uint64) b3 << 16 - | (uint64) b2 << 8 | (uint64) b1; + res = (uint64_t) b8 << 56 | (uint64_t) b7 << 48 + | (uint64_t) b6 << 40 | (uint64_t) b5 << 32 + | (uint64_t) b4 << 24 | (uint64_t) b3 << 16 + | (uint64_t) b2 << 8 | (uint64_t) b1; #endif return caml_copy_int64(res); } @@ -174,7 +174,7 @@ CAMLprim value caml_string_set32(value str, value index, value newval) CAMLprim value caml_string_set64(value str, value index, value newval) { unsigned char b1, b2, b3, b4, b5, b6, b7, b8; - int64 val; + int64_t val; intnat idx = Long_val(index); if (idx < 0 || idx + 7 >= caml_string_length(str)) caml_array_bound_error(); val = Int64_val(newval); @@ -308,7 +308,7 @@ CAMLexport value caml_alloc_sprintf(const char * format, ...) /* C99-compliant implementation */ va_start(args, format); /* "vsnprintf(dest, sz, format, args)" writes at most "sz" characters - into "dest", including the terminating '\0'. + into "dest", including the terminating '\0'. It returns the number of characters of the formatted string, excluding the terminating '\0'. */ n = vsnprintf(buf, sizeof(buf), format, args); @@ -316,7 +316,7 @@ CAMLexport value caml_alloc_sprintf(const char * format, ...) /* Allocate a Caml string with length "n" as computed by vsnprintf. */ res = caml_alloc_string(n); if (n < sizeof(buf)) { - /* All output characters were written to buf, including the + /* All output characters were written to buf, including the terminating '\0'. Just copy them to the result. */ memcpy(String_val(res), buf, n); } else { diff --git a/byterun/win32.c b/byterun/win32.c index b74b409803..67e9683211 100644 --- a/byterun/win32.c +++ b/byterun/win32.c @@ -103,7 +103,7 @@ CAMLexport char * caml_search_exe_in_path(char * name) caml_stat_free(fullname); return caml_strdup(name); } - if (retcode < fullnamelen) + if (retcode < fullnamelen) return fullname; caml_stat_free(fullname); fullnamelen = retcode + 1; diff --git a/config/Makefile.mingw b/config/Makefile.mingw index 63030dd1fe..d9e7607fec 100644 --- a/config/Makefile.mingw +++ b/config/Makefile.mingw @@ -109,7 +109,7 @@ NATIVECCLIBS=-lws2_32 CPP=$(BYTECC) -E ### Flexlink -FLEXLINK=flexlink -chain mingw -stack 16777216 +FLEXLINK=flexlink -chain mingw -stack 16777216 -link -static-libgcc FLEXDIR=$(shell $(FLEXLINK) -where) IFLEXDIR=-I"$(FLEXDIR)" MKDLL=$(FLEXLINK) diff --git a/config/auto-aux/int64align.c b/config/auto-aux/int64align.c index 5795e48449..c1439869f0 100644 --- a/config/auto-aux/int64align.c +++ b/config/auto-aux/int64align.c @@ -17,18 +17,18 @@ #include "m.h" #if defined(ARCH_INT64_TYPE) -typedef ARCH_INT64_TYPE int64; +typedef ARCH_INT64_TYPE int64_t; #elif SIZEOF_LONG == 8 -typedef long int64; +typedef long int64_t; #elif SIZEOF_LONGLONG == 8 -typedef long long int64; +typedef long long int64_t; #else #error "No 64-bit integer type available" #endif -int64 foo; +int64_t foo; -void access_int64(int64 *p) +void access_int64(int64_t *p) { foo = *p; } @@ -49,8 +49,8 @@ int main(void) signal(SIGBUS, sig_handler); #endif if(setjmp(failure) == 0) { - access_int64((int64 *) n); - access_int64((int64 *) (n+1)); + access_int64((int64_t *) n); + access_int64((int64_t *) (n+1)); res = 0; } else { res = 1; diff --git a/config/s-nt.h b/config/s-nt.h index 6df440b8a0..603b05054c 100644 --- a/config/s-nt.h +++ b/config/s-nt.h @@ -15,6 +15,9 @@ #define OCAML_OS_TYPE "Win32" +#ifdef __MINGW32__ +#define HAS_STDINT_H +#endif #undef BSD_SIGNALS #define HAS_STRERROR #define HAS_SOCKETS @@ -615,26 +615,6 @@ case "$target" in esac esac -# Check semantics of division and modulus - -sh ./runtest divmod.c -case $? in - 0) inf "Native division and modulus have round-towards-zero semantics," \ - "will use them." - echo "#undef NONSTANDARD_DIV_MOD" >> m.h;; - 1) inf "Native division and modulus do not have round-towards-zero" - "semantics, will use software emulation." - echo "#define NONSTANDARD_DIV_MOD" >> m.h;; - *) case $target in - *-*-mingw*) inf "Native division and modulus have round-towards-zero" \ - "semantics, will use them." - echo "#undef NONSTANDARD_DIV_MOD" >> m.h;; - *) wrn "Something went wrong while checking native division and modulus"\ - "please report it at http://http://caml.inria.fr/mantis/" - echo "#define NONSTANDARD_DIV_MOD" >> m.h;; - esac;; -esac - # Shared library support shared_libraries_supported=false @@ -768,6 +748,7 @@ if test $with_sharedlibs = "yes"; then x86_64-*-netbsd*) natdynlink=true;; i386-*-gnu0.3) natdynlink=true;; arm*-*-linux*) natdynlink=true;; + arm*-*-freebsd*) natdynlink=true;; aarch64-*-linux*) natdynlink=true;; esac fi @@ -818,6 +799,7 @@ case "$target" in armv7*-*-linux-gnueabi) arch=arm; model=armv7; system=linux_eabi;; armv6t2*-*-linux-gnueabi) arch=arm; model=armv6t2; system=linux_eabi;; armv6*-*-linux-gnueabi) arch=arm; model=armv6; system=linux_eabi;; + armv6*-*-freebsd*) arch=arm; model=armv6; system=freebsd;; armv5te*-*-linux-gnueabi) arch=arm; model=armv5te; system=linux_eabi;; armv5*-*-linux-gnueabi) arch=arm; model=armv5; system=linux_eabi;; arm*-*-linux-gnueabi) arch=arm; system=linux_eabi;; @@ -893,6 +875,8 @@ case "$arch,$system" in *gcc*) aspp="${TOOLPREF}gcc -c";; *) aspp="${TOOLPREF}as -P";; esac;; + arm,freebsd) as="${TOOLPREF}cc -c" + aspp="${TOOLPREF}cc -c";; *,freebsd) as="${TOOLPREF}as" aspp="${TOOLPREF}cc -c";; amd64,*|arm,*|arm64,*|i386,*|power,bsd*|sparc,*) @@ -1075,6 +1059,11 @@ if sh ./hasgot -i sys/types.h -i sys/socket.h -i netinet/in.h \ echo "#define HAS_IPV6" >> s.h fi +if sh ./hasgot -i stdint.h; then + inf "stdint.h found." + echo "#define HAS_STDINT_H" >> s.h +fi + if sh ./hasgot -i unistd.h; then inf "unistd.h found." echo "#define HAS_UNISTD" >> s.h diff --git a/debugger/main.ml b/debugger/main.ml index 52c1ed9952..60cd96a89a 100644 --- a/debugger/main.ml +++ b/debugger/main.ml @@ -193,7 +193,7 @@ let main () = (Unix.string_of_inet_addr Unix.inet_addr_loopback)^ ":"^ (string_of_int (10000 + ((Unix.getpid ()) mod 10000))) - | _ -> Filename.concat Filename.temp_dir_name + | _ -> Filename.concat (Filename.get_temp_dir_name ()) ("camldebug" ^ (string_of_int (Unix.getpid ()))) ); begin try diff --git a/driver/compenv.ml b/driver/compenv.ml index 32ecb937e9..82704fd8f9 100644 --- a/driver/compenv.ml +++ b/driver/compenv.ml @@ -169,6 +169,7 @@ let read_OCAMLPARAM ppf position = | "rectypes" -> set "rectypes" [ recursive_types ] v | "safe-string" -> clear "safe-string" [ unsafe_string ] v | "strict-sequence" -> set "strict-sequence" [ strict_sequence ] v + | "strict-formats" -> set "strict-formats" [ strict_formats ] v | "thread" -> set "thread" [ use_threads ] v | "unsafe" -> set "unsafe" [ fast ] v | "verbose" -> set "verbose" [ verbose ] v diff --git a/driver/compile.ml b/driver/compile.ml index fb003c7ea1..3b5d2ae077 100644 --- a/driver/compile.ml +++ b/driver/compile.ml @@ -92,7 +92,7 @@ let implementation ppf sourcefile outputprefix = ++ print_if ppf Clflags.dump_lambda Printlambda.lambda ++ Bytegen.compile_implementation modulename ++ print_if ppf Clflags.dump_instr Printinstr.instrlist - ++ Emitcode.to_file oc modulename; + ++ Emitcode.to_file oc modulename objfile; Warnings.check_fatal (); close_out oc; Stypes.dump (Some (outputprefix ^ ".annot")) diff --git a/driver/main.ml b/driver/main.ml index 4b1c7264aa..f8358a0cbd 100644 --- a/driver/main.ml +++ b/driver/main.ml @@ -115,6 +115,7 @@ module Options = Main_args.Make_bytecomp_options (struct let _safe_string = unset unsafe_string let _short_paths = unset real_paths let _strict_sequence = set strict_sequence + let _strict_formats = set strict_formats let _thread = set use_threads let _vmthread = set use_vmthreads let _unsafe = set fast diff --git a/driver/main_args.ml b/driver/main_args.ml index dd04352ea3..4f9668c750 100644 --- a/driver/main_args.ml +++ b/driver/main_args.ml @@ -161,7 +161,8 @@ let mk_no_app_funct f = ;; let mk_no_float_const_prop f = - "-no-float-const-prop", Arg.Unit f, " Deactivate constant propagation for floating-point operations" + "-no-float-const-prop", Arg.Unit f, + " Deactivate constant propagation for floating-point operations" ;; let mk_noassert f = @@ -446,6 +447,21 @@ let mk_dstartup f = "-dstartup", Arg.Unit f, " (undocumented)" ;; +let mk_opaque f = + "-opaque", Arg.Unit f, + " Does not generate cross-module optimization information\n\ + \ (reduces necessary recompilation on module change)" +;; + +let mk_strict_formats f = + "-strict-formats", Arg.Unit f, + " Reject invalid formats accepted by legacy implementations\n\ + \ (Warning: Invalid formats may behave differently from\n\ + \ previous OCaml versions, and will become always-rejected\n\ + \ in future OCaml versions. You should use this flag\n\ + \ to detect and fix invalid formats.)" +;; + let mk__ f = "-", Arg.String f, "<file> Treat <file> as a file name (even if it starts with `-')" @@ -467,6 +483,7 @@ module type Common_options = sig val _safe_string : unit -> unit val _short_paths : unit -> unit val _strict_sequence : unit -> unit + val _strict_formats : unit -> unit val _unsafe : unit -> unit val _unsafe_string : unit -> unit val _version : unit -> unit @@ -515,7 +532,6 @@ module type Compiler_options = sig val _v : unit -> unit val _verbose : unit -> unit val _where : unit -> unit - val _nopervasives : unit -> unit end ;; @@ -578,6 +594,7 @@ module type Optcomp_options = sig val _pp : string -> unit val _S : unit -> unit val _shared : unit -> unit + val _opaque : unit -> unit end;; module type Opttop_options = sig @@ -644,6 +661,7 @@ struct mk_safe_string F._safe_string; mk_short_paths F._short_paths; mk_strict_sequence F._strict_sequence; + mk_strict_formats F._strict_formats; mk_thread F._thread; mk_unsafe F._unsafe; mk_unsafe_string F._unsafe_string; @@ -694,6 +712,7 @@ struct mk_short_paths F._short_paths; mk_stdin F._stdin; mk_strict_sequence F._strict_sequence; + mk_strict_formats F._strict_formats; mk_unsafe F._unsafe; mk_unsafe_string F._unsafe_string; mk_version F._version; @@ -760,6 +779,7 @@ struct mk_shared F._shared; mk_short_paths F._short_paths; mk_strict_sequence F._strict_sequence; + mk_strict_formats F._strict_formats; mk_thread F._thread; mk_unsafe F._unsafe; mk_unsafe_string F._unsafe_string; @@ -794,6 +814,7 @@ struct mk_dscheduling F._dscheduling; mk_dlinear F._dlinear; mk_dstartup F._dstartup; + mk_opaque F._opaque; ] end;; @@ -822,6 +843,7 @@ module Make_opttop_options (F : Opttop_options) = struct mk_short_paths F._short_paths; mk_stdin F._stdin; mk_strict_sequence F._strict_sequence; + mk_strict_formats F._strict_formats; mk_unsafe F._unsafe; mk_unsafe_string F._unsafe_string; mk_version F._version; diff --git a/driver/main_args.mli b/driver/main_args.mli index e4a9c58f5e..95b7c69e38 100644 --- a/driver/main_args.mli +++ b/driver/main_args.mli @@ -26,6 +26,7 @@ module type Common_options = sig val _safe_string : unit -> unit val _short_paths : unit -> unit val _strict_sequence : unit -> unit + val _strict_formats : unit -> unit val _unsafe : unit -> unit val _unsafe_string : unit -> unit val _version : unit -> unit @@ -137,6 +138,7 @@ module type Optcomp_options = sig val _pp : string -> unit val _S : unit -> unit val _shared : unit -> unit + val _opaque : unit -> unit end;; module type Opttop_options = sig diff --git a/driver/optmain.ml b/driver/optmain.ml index a520a8ce14..947d43073a 100644 --- a/driver/optmain.ml +++ b/driver/optmain.ml @@ -114,6 +114,7 @@ module Options = Main_args.Make_optcomp_options (struct let _safe_string = clear unsafe_string let _short_paths = clear real_paths let _strict_sequence = set strict_sequence + let _strict_formats = set strict_formats let _shared () = shared := true; dlcode := true let _S = set keep_asm_file let _thread = set use_threads @@ -149,6 +150,7 @@ module Options = Main_args.Make_optcomp_options (struct let _dscheduling = set dump_scheduling let _dlinear = set dump_linear let _dstartup = set keep_startup_file + let _opaque = set opaque let anonymous = anonymous end);; diff --git a/experimental/doligez/check-bounds.diff b/experimental/doligez/check-bounds.diff new file mode 100644 index 0000000000..c2e0795212 --- /dev/null +++ b/experimental/doligez/check-bounds.diff @@ -0,0 +1,149 @@ +Patch taken from: + https://github.com/mshinwell/ocaml/commits/4.02-block-bounds + +diff --git a/asmcomp/cmmgen.ml b/asmcomp/cmmgen.ml +index 01eff9c..b498b58 100644 +--- a/asmcomp/cmmgen.ml ++++ b/asmcomp/cmmgen.ml +@@ -22,6 +22,13 @@ open Clambda + open Cmm + open Cmx_format + ++let do_check_field_access = true ++(* ++ match try Some (Sys.getenv "BOUNDS") with Not_found -> None with ++ | None | Some "" -> false ++ | Some _ -> true ++*) ++ + (* Local binding of complex expressions *) + + let bind name arg fn = +@@ -494,6 +501,35 @@ let get_tag ptr = + let get_size ptr = + Cop(Clsr, [header ptr; Cconst_int 10]) + ++(* Bounds checks upon field access, for debugging the compiler *) ++ ++let check_field_access ptr field_index if_success = ++ if not do_check_field_access then ++ if_success ++ else ++ let field_index = Cconst_int field_index in ++ (* If [ptr] points at an infix header, we need to move it back to the "main" ++ [Closure_tag] header. *) ++ let ptr = ++ Cifthenelse (Cop (Ccmpi Cne, [get_tag ptr; Cconst_int Obj.infix_tag]), ++ ptr, ++ Cop (Csuba, [ptr; ++ Cop (Cmuli, [get_size ptr (* == Infix_offset_val(ptr) *); ++ Cconst_int size_addr])])) ++ in ++ let not_too_small = Cop (Ccmpi Cge, [field_index; Cconst_int 0]) in ++ let not_too_big = Cop (Ccmpi Clt, [field_index; get_size ptr]) in ++ let failure = ++ Cop (Cextcall ("caml_field_access_out_of_bounds_error", typ_addr, false, ++ Debuginfo.none), ++ [ptr; field_index]) ++ in ++ Cifthenelse (not_too_small, ++ Cifthenelse (not_too_big, ++ if_success, ++ failure), ++ failure) ++ + (* Array indexing *) + + let log2_size_addr = Misc.log2 size_addr +@@ -1550,13 +1586,18 @@ and transl_prim_1 p arg dbg = + return_unit(remove_unit (transl arg)) + (* Heap operations *) + | Pfield n -> +- get_field (transl arg) n ++ let ptr = transl arg in ++ let body = get_field ptr n in ++ check_field_access ptr n body + | Pfloatfield n -> + let ptr = transl arg in +- box_float( +- Cop(Cload Double_u, +- [if n = 0 then ptr +- else Cop(Cadda, [ptr; Cconst_int(n * size_float)])])) ++ let body = ++ box_float( ++ Cop(Cload Double_u, ++ [if n = 0 then ptr ++ else Cop(Cadda, [ptr; Cconst_int(n * size_float)])])) ++ in ++ check_field_access ptr n body + | Pint_as_pointer -> + Cop(Cadda, [transl arg; Cconst_int (-1)]) + (* Exceptions *) +@@ -1649,20 +1690,25 @@ and transl_prim_1 p arg dbg = + and transl_prim_2 p arg1 arg2 dbg = + match p with + (* Heap operations *) +- Psetfield(n, ptr) -> +- if ptr then +- return_unit(Cop(Cextcall("caml_modify", typ_void, false,Debuginfo.none), +- [field_address (transl arg1) n; transl arg2])) +- else +- return_unit(set_field (transl arg1) n (transl arg2)) ++ Psetfield(n, is_ptr) -> ++ let ptr = transl arg1 in ++ let body = ++ if is_ptr then ++ Cop(Cextcall("caml_modify", typ_void, false,Debuginfo.none), ++ [field_address ptr n; transl arg2]) ++ else ++ set_field ptr n (transl arg2) ++ in ++ check_field_access ptr n (return_unit body) + | Psetfloatfield n -> + let ptr = transl arg1 in +- return_unit( ++ let body = + Cop(Cstore Double_u, + [if n = 0 then ptr + else Cop(Cadda, [ptr; Cconst_int(n * size_float)]); +- transl_unbox_float arg2])) +- ++ transl_unbox_float arg2]) ++ in ++ check_field_access ptr n (return_unit body) + (* Boolean operations *) + | Psequand -> + Cifthenelse(test_bool(transl arg1), transl arg2, Cconst_int 1) +diff --git a/asmrun/fail.c b/asmrun/fail.c +index cb2c1cb..4f67c74 100644 +--- a/asmrun/fail.c ++++ b/asmrun/fail.c +@@ -15,6 +15,7 @@ + + #include <stdio.h> + #include <signal.h> ++#include <assert.h> + #include "alloc.h" + #include "fail.h" + #include "io.h" +@@ -180,3 +181,20 @@ int caml_is_special_exception(value exn) { + || exn == (value) caml_exn_Assert_failure + || exn == (value) caml_exn_Undefined_recursive_module; + } ++ ++void caml_field_access_out_of_bounds_error(value v_block, intnat index) ++{ ++ assert(Is_block(v_block)); ++ fprintf(stderr, "Fatal error: out-of-bounds access to field %ld ", index); ++ fprintf(stderr, "of block at %p (%s, size %ld, tag %d)\n", ++ (void*) v_block, ++ Is_young(v_block) ? "in minor heap" ++ : Is_in_heap(v_block) ? "in major heap" ++ : Is_in_value_area(v_block) ? "in static data" ++ : "out-of-heap", ++ (long) Wosize_val(v_block), (int) Tag_val(v_block)); ++ fflush(stderr); ++ /* This error may have occurred in places where it is not reasonable to ++ attempt to continue. */ ++ abort(); ++} diff --git a/lex/compact.ml b/lex/compact.ml index 1f620ab8df..f468a557d6 100644 --- a/lex/compact.ml +++ b/lex/compact.ml @@ -92,13 +92,13 @@ type t_compact = mutable c_last_used : int ; } let create_compact () = - { c_trans = Array.create 1024 0 ; - c_check = Array.create 1024 (-1) ; + { c_trans = Array.make 1024 0 ; + c_check = Array.make 1024 (-1) ; c_last_used = 0 ; } let reset_compact c = - c.c_trans <- Array.create 1024 0 ; - c.c_check <- Array.create 1024 (-1) ; + c.c_trans <- Array.make 1024 0 ; + c.c_check <- Array.make 1024 (-1) ; c.c_last_used <- 0 (* One compacted table for transitions, one other for memory actions *) @@ -110,9 +110,9 @@ let grow_compact c = let old_trans = c.c_trans and old_check = c.c_check in let n = Array.length old_trans in - c.c_trans <- Array.create (2*n) 0; + c.c_trans <- Array.make (2*n) 0; Array.blit old_trans 0 c.c_trans 0 c.c_last_used; - c.c_check <- Array.create (2*n) (-1); + c.c_check <- Array.make (2*n) (-1); Array.blit old_check 0 c.c_check 0 c.c_last_used let do_pack state_num orig compact = @@ -142,8 +142,8 @@ let do_pack state_num orig compact = (base, default) let pack_moves state_num move_t = - let move_v = Array.create 257 0 - and move_m = Array.create 257 0 in + let move_v = Array.make 257 0 + and move_m = Array.make 257 0 in for i = 0 to 256 do let act,c = move_t.(i) in move_v.(i) <- (match act with Backtrack -> -1 | Goto n -> n) ; @@ -175,12 +175,12 @@ type lex_tables = let compact_tables state_v = let n = Array.length state_v in - let base = Array.create n 0 - and backtrk = Array.create n (-1) - and default = Array.create n 0 - and base_code = Array.create n 0 - and backtrk_code = Array.create n 0 - and default_code = Array.create n 0 in + let base = Array.make n 0 + and backtrk = Array.make n (-1) + and default = Array.make n 0 + and base_code = Array.make n 0 + and backtrk_code = Array.make n 0 + and default_code = Array.make n 0 in for i = 0 to n - 1 do match state_v.(i) with | Perform (n,c) -> diff --git a/lex/cset.ml b/lex/cset.ml index 8c3d176fa5..f4581ba374 100644 --- a/lex/cset.ml +++ b/lex/cset.ml @@ -81,7 +81,7 @@ let complement s = diff all_chars s let env_to_array env = match env with | [] -> assert false | (_,x)::rem -> - let res = Array.create 257 x in + let res = Array.make 257 x in List.iter (fun (c,y) -> List.iter diff --git a/lex/lexgen.ml b/lex/lexgen.ml index 035e3fe6c0..503b08fa49 100644 --- a/lex/lexgen.ml +++ b/lex/lexgen.ml @@ -589,7 +589,7 @@ let rec firstpos = function (* Berry-sethi followpos *) let followpos size entry_list = - let v = Array.create size TransSet.empty in + let v = Array.make size TransSet.empty in let rec fill s = function | Empty|Action _|Tag _ -> () | Chars (n,_) -> v.(n) <- s @@ -1132,7 +1132,7 @@ let make_tag_entry id start act a r = match a with | _ -> r let extract_tags l = - let envs = Array.create (List.length l) TagMap.empty in + let envs = Array.make (List.length l) TagMap.empty in List.iter (fun (act,m,_) -> envs.(act) <- @@ -1186,7 +1186,7 @@ let make_dfa lexdef = done ; eprintf "%d states\n" !next_state_num ; *) - let actions = Array.create !next_state_num (Perform (0,[])) in + let actions = Array.make !next_state_num (Perform (0,[])) in List.iter (fun (act, i) -> actions.(i) <- act) states; (* Useless state reset, so as to restrict GC roots *) reset_state () ; diff --git a/lex/output.ml b/lex/output.ml index 2e7700257c..638260c2b4 100644 --- a/lex/output.ml +++ b/lex/output.ml @@ -77,7 +77,7 @@ let output_entry sourcefile ic oc has_refill oci e = output_args e.auto_args (fun oc x -> if x > 0 then - fprintf oc "lexbuf.Lexing.lex_mem <- Array.create %d (-1) ; " x) + fprintf oc "lexbuf.Lexing.lex_mem <- Array.make %d (-1) ; " x) e.auto_mem_size (output_memory_actions " ") init_moves e.auto_name diff --git a/lex/outputbis.ml b/lex/outputbis.ml index 333cbc2a22..709ec0eec8 100644 --- a/lex/outputbis.ml +++ b/lex/outputbis.ml @@ -20,7 +20,7 @@ let output_auto_defs oc has_refill = output_string 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_mem <- Array.make mem_size (-1) ;\ \n lexbuf.Lexing.lex_start_pos <- pos ;\ \n lexbuf.Lexing.lex_last_pos <- pos ;\ \n lexbuf.Lexing.lex_last_action <- -1\ diff --git a/lex/table.ml b/lex/table.ml index fb5a6128eb..715d90758d 100644 --- a/lex/table.ml +++ b/lex/table.ml @@ -15,12 +15,12 @@ type 'a t = {mutable next : int ; mutable data : 'a array} let default_size = 32 ;; -let create x = {next = 0 ; data = Array.create default_size x} +let create x = {next = 0 ; data = Array.make default_size x} and reset t = t.next <- 0 ;; let incr_table table new_size = - let t = Array.create new_size table.data.(0) in + let t = Array.make new_size table.data.(0) in Array.blit table.data 0 t 0 (Array.length table.data) ; table.data <- t diff --git a/man/ocamldoc.m b/man/ocamldoc.m index b25833aec7..ca0a233480 100644 --- a/man/ocamldoc.m +++ b/man/ocamldoc.m @@ -181,7 +181,7 @@ Several .B -load options can be given. .TP -.BI \-m flags +.BI \-m \ flags Specify merge options between interfaces and implementations. .I flags can be one or several of the following characters: @@ -442,11 +442,11 @@ option: Generate man pages only for modules, module types, classes and class types, instead of pages for all elements. .TP -.BI \-man\-suffix suffix +.BI \-man\-suffix \ suffix Set the suffix used for generated man filenames. Default is o, as in .IR List.o . .TP -.BI \-man\-section section +.BI \-man\-section \ section Set the section number used for generated man filenames. Default is 3. diff --git a/man/ocamlopt.m b/man/ocamlopt.m index 98ff86bf95..b1b173afa8 100644 --- a/man/ocamlopt.m +++ b/man/ocamlopt.m @@ -682,17 +682,13 @@ Disable Thumb/Thumb-2 code generation .P The default values for target architecture, floating-point hardware and thumb usage were selected at configure-time when building -.BR ocamlopt -itself. This configuration can be inspected using -.BR ocamlopt -.BR \-config . +.B ocamlopt +itself. This configuration can be inspected using +.BR ocamlopt\ \-config . Target architecture depends on the "model" setting, while floating-point hardware and thumb support are determined from the ABI setting in "system" ( -.BR linux_eabi -or -.BR linux_eabihf -). +.BR linux_eabi or linux_eabihf ). .SH SEE ALSO .BR ocamlc (1). diff --git a/ocamlbuild/.depend b/ocamlbuild/.depend index c983ee1288..3b67d873d4 100644 --- a/ocamlbuild/.depend +++ b/ocamlbuild/.depend @@ -1,6 +1,6 @@ bool.cmi : command.cmi : tags.cmi signatures.cmi -configuration.cmi : tags.cmi pathname.cmi +configuration.cmi : tags.cmi pathname.cmi loc.cmi digest_cache.cmi : discard_printf.cmi : display.cmi : tags.cmi @@ -27,10 +27,10 @@ ocaml_tools.cmi : tags.cmi rule.cmi pathname.cmi command.cmi ocaml_utils.cmi : tags.cmi pathname.cmi command.cmi ocamlbuild.cmi : ocamlbuild_executor.cmi : -ocamlbuild_plugin.cmi : ocamlbuild_pack.cmi -ocamlbuild_unix_plugin.cmi : ocamlbuild_pack.cmi +ocamlbuild_plugin.cmi : +ocamlbuild_unix_plugin.cmi : ocamlbuild_where.cmi : -ocamlbuildlight.cmi : ocamlbuild_pack.cmi +ocamlbuildlight.cmi : options.cmi : slurp.cmi signatures.cmi command.cmi param_tags.cmi : tags.cmi loc.cmi pathname.cmi : signatures.cmi @@ -48,13 +48,15 @@ tools.cmi : tags.cmi pathname.cmi bool.cmo : bool.cmi bool.cmx : bool.cmi command.cmo : tags.cmi shell.cmi param_tags.cmi my_unix.cmi my_std.cmi \ - log.cmi lexers.cmi command.cmi + log.cmi lexers.cmi const.cmo command.cmi command.cmx : tags.cmx shell.cmx param_tags.cmx my_unix.cmx my_std.cmx \ - log.cmx lexers.cmx command.cmi + log.cmx lexers.cmx const.cmx command.cmi configuration.cmo : tags.cmi param_tags.cmi my_std.cmi log.cmi loc.cmi \ - lexers.cmi glob.cmi configuration.cmi + lexers.cmi glob.cmi const.cmo configuration.cmi configuration.cmx : tags.cmx param_tags.cmx my_std.cmx log.cmx loc.cmx \ - lexers.cmx glob.cmx configuration.cmi + lexers.cmx glob.cmx const.cmx configuration.cmi +const.cmo : +const.cmx : digest_cache.cmo : shell.cmi pathname.cmi options.cmi my_unix.cmi my_std.cmi \ digest_cache.cmi digest_cache.cmx : shell.cmx pathname.cmx options.cmx my_unix.cmx my_std.cmx \ @@ -67,8 +69,10 @@ exit_codes.cmo : exit_codes.cmi exit_codes.cmx : exit_codes.cmi fda.cmo : pathname.cmi options.cmi log.cmi hygiene.cmi fda.cmi fda.cmx : pathname.cmx options.cmx log.cmx hygiene.cmx fda.cmi -findlib.cmo : my_unix.cmi my_std.cmi lexers.cmi command.cmi findlib.cmi -findlib.cmx : my_unix.cmx my_std.cmx lexers.cmx command.cmx findlib.cmi +findlib.cmo : my_unix.cmi my_std.cmi lexers.cmi const.cmo command.cmi \ + findlib.cmi +findlib.cmx : my_unix.cmx my_std.cmx lexers.cmx const.cmx command.cmx \ + findlib.cmi flags.cmo : tags.cmi param_tags.cmi log.cmi command.cmi bool.cmi flags.cmi flags.cmx : tags.cmx param_tags.cmx log.cmx command.cmx bool.cmx flags.cmi glob.cmo : my_std.cmi glob_lexer.cmi glob_ast.cmi bool.cmi glob.cmi @@ -93,14 +97,14 @@ main.cmo : tools.cmi tags.cmi solver.cmi slurp.cmi shell.cmi rule.cmi \ resource.cmi report.cmi plugin.cmi pathname.cmi param_tags.cmi \ options.cmi ocaml_utils.cmi ocaml_specific.cmi ocaml_dependencies.cmi \ my_unix.cmi my_std.cmi log.cmi loc.cmi lexers.cmi hooks.cmi flags.cmi \ - fda.cmi exit_codes.cmi digest_cache.cmi configuration.cmi command.cmi \ - main.cmi + fda.cmi exit_codes.cmi digest_cache.cmi const.cmo configuration.cmi \ + command.cmi main.cmi main.cmx : tools.cmx tags.cmx solver.cmx slurp.cmx shell.cmx rule.cmx \ resource.cmx report.cmx plugin.cmx pathname.cmx param_tags.cmx \ options.cmx ocaml_utils.cmx ocaml_specific.cmx ocaml_dependencies.cmx \ my_unix.cmx my_std.cmx log.cmx loc.cmx lexers.cmx hooks.cmx flags.cmx \ - fda.cmx exit_codes.cmx digest_cache.cmx configuration.cmx command.cmx \ - main.cmi + fda.cmx exit_codes.cmx digest_cache.cmx const.cmx configuration.cmx \ + command.cmx main.cmi my_std.cmo : my_std.cmi my_std.cmx : my_std.cmi my_unix.cmo : my_std.cmi my_unix.cmi @@ -132,18 +136,19 @@ ocaml_tools.cmx : tools.cmx tags.cmx rule.cmx pathname.cmx options.cmx \ ocaml_utils.cmx ocaml_compiler.cmx my_std.cmx flags.cmx command.cmx \ ocaml_tools.cmi ocaml_utils.cmo : tools.cmi tags.cmi pathname.cmi param_tags.cmi options.cmi \ - my_std.cmi log.cmi lexers.cmi flags.cmi command.cmi ocaml_utils.cmi + my_std.cmi log.cmi lexers.cmi flags.cmi const.cmo command.cmi \ + ocaml_utils.cmi ocaml_utils.cmx : tools.cmx tags.cmx pathname.cmx param_tags.cmx options.cmx \ - my_std.cmx log.cmx lexers.cmx flags.cmx command.cmx ocaml_utils.cmi + my_std.cmx log.cmx lexers.cmx flags.cmx const.cmx command.cmx \ + ocaml_utils.cmi ocamlbuild.cmo : ocamlbuild_unix_plugin.cmi ocamlbuild.cmi ocamlbuild.cmx : ocamlbuild_unix_plugin.cmx ocamlbuild.cmi ocamlbuild_config.cmo : ocamlbuild_config.cmx : ocamlbuild_executor.cmo : ocamlbuild_executor.cmi ocamlbuild_executor.cmx : ocamlbuild_executor.cmi -ocamlbuild_pack.cmo : ocamlbuild_pack.cmi -ocamlbuild_plugin.cmo : ocamlbuild_plugin.cmi ocamlbuild_pack.cmo -ocamlbuild_plugin.cmx : ocamlbuild_plugin.cmi ocamlbuild_pack.cmx +ocamlbuild_plugin.cmo : ocamlbuild_plugin.cmi +ocamlbuild_plugin.cmx : ocamlbuild_plugin.cmi ocamlbuild_unix_plugin.cmo : ocamlbuild_executor.cmi my_unix.cmi my_std.cmi \ exit_codes.cmi ocamlbuild_unix_plugin.cmi ocamlbuild_unix_plugin.cmx : ocamlbuild_executor.cmx my_unix.cmx my_std.cmx \ @@ -153,9 +158,9 @@ ocamlbuild_where.cmx : ocamlbuild_config.cmx ocamlbuild_where.cmi ocamlbuildlight.cmo : ocamlbuildlight.cmi ocamlbuildlight.cmx : ocamlbuildlight.cmi options.cmo : shell.cmi ocamlbuild_where.cmi ocamlbuild_config.cmo \ - my_std.cmi log.cmi lexers.cmi command.cmi options.cmi + my_std.cmi log.cmi lexers.cmi const.cmo command.cmi options.cmi options.cmx : shell.cmx ocamlbuild_where.cmx ocamlbuild_config.cmx \ - my_std.cmx log.cmx lexers.cmx command.cmx options.cmi + my_std.cmx log.cmx lexers.cmx const.cmx command.cmx options.cmi param_tags.cmo : tags.cmi my_std.cmi log.cmi loc.cmi lexers.cmi \ param_tags.cmi param_tags.cmx : tags.cmx my_std.cmx log.cmx loc.cmx lexers.cmx \ @@ -166,10 +171,10 @@ pathname.cmx : shell.cmx options.cmx my_unix.cmx my_std.cmx log.cmx glob.cmx \ pathname.cmi plugin.cmo : tools.cmi tags.cmi shell.cmi rule.cmi pathname.cmi \ param_tags.cmi options.cmi ocamlbuild_where.cmi my_unix.cmi my_std.cmi \ - log.cmi command.cmi plugin.cmi + log.cmi const.cmo command.cmi plugin.cmi plugin.cmx : tools.cmx tags.cmx shell.cmx rule.cmx pathname.cmx \ param_tags.cmx options.cmx ocamlbuild_where.cmx my_unix.cmx my_std.cmx \ - log.cmx command.cmx plugin.cmi + log.cmx const.cmx command.cmx plugin.cmi ppcache.cmo : shell.cmi pathname.cmi my_std.cmi log.cmi command.cmi \ ppcache.cmi ppcache.cmx : shell.cmx pathname.cmx my_std.cmx log.cmx command.cmx \ @@ -178,10 +183,10 @@ report.cmo : solver.cmi resource.cmi my_std.cmi log.cmi glob.cmi report.cmi report.cmx : solver.cmx resource.cmx my_std.cmx log.cmx glob.cmx report.cmi resource.cmo : slurp.cmi shell.cmi pathname.cmi options.cmi my_unix.cmi \ my_std.cmi log.cmi lexers.cmi glob_ast.cmi glob.cmi digest_cache.cmi \ - command.cmi resource.cmi + const.cmo command.cmi resource.cmi resource.cmx : slurp.cmx shell.cmx pathname.cmx options.cmx my_unix.cmx \ my_std.cmx log.cmx lexers.cmx glob_ast.cmx glob.cmx digest_cache.cmx \ - command.cmx resource.cmi + const.cmx command.cmx resource.cmi rule.cmo : shell.cmi resource.cmi pathname.cmi options.cmi my_std.cmi \ log.cmi digest_cache.cmi command.cmi rule.cmi rule.cmx : shell.cmx resource.cmx pathname.cmx options.cmx my_std.cmx \ diff --git a/ocamlbuild/Makefile b/ocamlbuild/Makefile index 9f5dda3269..b40d0eada1 100644 --- a/ocamlbuild/Makefile +++ b/ocamlbuild/Makefile @@ -23,6 +23,7 @@ COMPFLAGS= -warn-error A -w L -w R -w Z -I ../otherlibs/$(UNIXLIB) -safe-string LINKFLAGS= -I ../otherlibs/$(UNIXLIB) PACK_CMO=\ + const.cmo \ loc.cmo \ discard_printf.cmo \ signatures.cmi \ diff --git a/ocamlbuild/command.ml b/ocamlbuild/command.ml index f5887cd6aa..fc6e07cf43 100644 --- a/ocamlbuild/command.ml +++ b/ocamlbuild/command.ml @@ -99,10 +99,7 @@ let env_path = lazy begin Lexers.parse_environment_path in let paths = - try - parse_path (Lexing.from_string path_var) - with Lexers.Error (msg,pos) -> raise (Lexers.Error ("$PATH: " ^ msg, pos)) - in + parse_path Const.Source.path (Lexing.from_string path_var) in let norm_current_dir_name path = if path = "" then Filename.current_dir_name else path in diff --git a/ocamlbuild/configuration.ml b/ocamlbuild/configuration.ml index 551acae6d8..6290e60a95 100644 --- a/ocamlbuild/configuration.ml +++ b/ocamlbuild/configuration.ml @@ -18,31 +18,35 @@ open Lexers type t = Lexers.conf -let acknowledge_config config = - let ack (tag, loc) = Param_tags.acknowledge (Some loc) tag in +let acknowledge_config source config = + let ack (tag, loc) = Param_tags.acknowledge source (Some loc) tag in List.iter (fun (_, config) -> List.iter ack config.plus_tags) config let cache = Hashtbl.create 107 let (configs, add_config) = let configs = ref [] in (fun () -> !configs), - (fun config -> - acknowledge_config config; + (fun source config -> + acknowledge_config source config; configs := config :: !configs; Hashtbl.clear cache) let parse_lexbuf ?dir source lexbuf = - lexbuf.Lexing.lex_curr_p <- - { lexbuf.Lexing.lex_curr_p with Lexing.pos_fname = source }; - let conf = Lexers.conf_lines dir lexbuf in - add_config conf + let conf = Lexers.conf_lines dir source lexbuf in + add_config source conf -let parse_string s = - parse_lexbuf (Printf.sprintf "STRING(%s)" s) (Lexing.from_string s) +let parse_string ?source s = + let source = match source with + | Some source -> source + | None -> Const.Source.configuration + in + parse_lexbuf source (lexbuf_of_string s) let parse_file ?dir file = with_input_file file begin fun ic -> - parse_lexbuf ?dir file (Lexing.from_channel ic) + let lexbuf = Lexing.from_channel ic in + set_lexbuf_fname file lexbuf; + parse_lexbuf ?dir Const.Source.file lexbuf end let key_match = Glob.eval diff --git a/ocamlbuild/configuration.mli b/ocamlbuild/configuration.mli index 1f8856aac0..2bfd6bb880 100644 --- a/ocamlbuild/configuration.mli +++ b/ocamlbuild/configuration.mli @@ -18,7 +18,7 @@ (** Incorporate a newline-separated configuration string into the current configuration. Will usually raising an [Invalid_arg] with an appropriately explicit message in case of error. *) -val parse_string : string -> unit +val parse_string : ?source:Loc.source -> string -> unit (** [parse_file ?dir fn] incorporates the configuration file named [fn], prefixing its glob patterns with [dir] if given. *) diff --git a/ocamlbuild/const.ml b/ocamlbuild/const.ml new file mode 100644 index 0000000000..dac8778908 --- /dev/null +++ b/ocamlbuild/const.ml @@ -0,0 +1,11 @@ +module Source = struct + let file = "file" + let command_line = "command-line" + let path = "path" + let ocamlfind_query = "ocamlfind query" + let ocamldep = "ocamldep" + let target_pattern = "target pattern" + let builtin = "builtin configuration" + let configuration = "configuration" + let plugin_tag = "plugin tag" +end diff --git a/ocamlbuild/findlib.ml b/ocamlbuild/findlib.ml index 199bc4fd24..18f4d2c956 100644 --- a/ocamlbuild/findlib.ml +++ b/ocamlbuild/findlib.ml @@ -74,15 +74,19 @@ let rec query name = with Not_found -> try let n, d, v, a_byte, lo, l = - run_and_parse Lexers.ocamlfind_query + run_and_parse + (Lexers.ocamlfind_query Const.Source.ocamlfind_query) "%s query -l -predicates byte %s" ocamlfind name in let a_native = - run_and_parse Lexers.trim_blanks + run_and_parse + (Lexers.trim_blanks Const.Source.ocamlfind_query) "%s query -a-format -predicates native %s" ocamlfind name in let deps = - run_and_parse Lexers.blank_sep_strings "%s query -r -p-format %s" ocamlfind name + run_and_parse + (Lexers.blank_sep_strings Const.Source.ocamlfind_query) + "%s query -r -p-format %s" ocamlfind name in let deps = List.filter ((<>) n) deps in let deps = diff --git a/ocamlbuild/lexers.mli b/ocamlbuild/lexers.mli index a59d7589b9..5b14f04c0e 100644 --- a/ocamlbuild/lexers.mli +++ b/ocamlbuild/lexers.mli @@ -20,29 +20,29 @@ type conf_values = type conf = (Glob.globber * conf_values) list -val ocamldep_output : Lexing.lexbuf -> (string * string list) list -val space_sep_strings : Lexing.lexbuf -> string list -val blank_sep_strings : Lexing.lexbuf -> string list -val comma_sep_strings : Lexing.lexbuf -> string list -val comma_or_blank_sep_strings : Lexing.lexbuf -> string list -val trim_blanks : Lexing.lexbuf -> string +val ocamldep_output : Loc.source -> Lexing.lexbuf -> (string * string list) list +val space_sep_strings : Loc.source -> Lexing.lexbuf -> string list +val blank_sep_strings : Loc.source -> Lexing.lexbuf -> string list +val comma_sep_strings : Loc.source -> Lexing.lexbuf -> string list +val comma_or_blank_sep_strings : Loc.source -> Lexing.lexbuf -> string list +val trim_blanks : Loc.source -> Lexing.lexbuf -> string (* Parse an environment path (i.e. $PATH). This is a colon separated string. Note: successive colons means an empty string. Example: ":aaa:bbb:::ccc:" -> [""; "aaa"; "bbb"; ""; ""; "ccc"; ""] *) -val parse_environment_path : Lexing.lexbuf -> string list +val parse_environment_path : Loc.source -> Lexing.lexbuf -> string list (* Same one, for Windows (PATH is ;-separated) *) -val parse_environment_path_w : Lexing.lexbuf -> string list +val parse_environment_path_w : Loc.source -> Lexing.lexbuf -> string list -val conf_lines : string option -> Lexing.lexbuf -> conf -val path_scheme : bool -> Lexing.lexbuf -> +val conf_lines : string option -> Loc.source -> Lexing.lexbuf -> conf +val path_scheme : bool -> Loc.source -> Lexing.lexbuf -> [ `Word of string | `Var of (string * Glob.globber) ] list -val ocamlfind_query : Lexing.lexbuf -> +val ocamlfind_query : Loc.source -> Lexing.lexbuf -> string * string * string * string * string * string -val tag_gen : Lexing.lexbuf -> string * string option +val tag_gen : Loc.source -> Lexing.lexbuf -> string * string option diff --git a/ocamlbuild/lexers.mll b/ocamlbuild/lexers.mll index 797337d852..d0b8cfdb12 100644 --- a/ocamlbuild/lexers.mll +++ b/ocamlbuild/lexers.mll @@ -15,8 +15,10 @@ { exception Error of (string * Loc.location) -let error lexbuf fmt = - Printf.ksprintf (fun s -> raise (Error (s, Loc.of_lexbuf lexbuf))) fmt +let error source lexbuf fmt = + Printf.ksprintf (fun s -> + raise (Error (s, Loc.of_lexbuf source lexbuf)) + ) fmt open Glob_ast @@ -28,13 +30,16 @@ type conf = (Glob.globber * conf_values) list let empty = { plus_tags = []; minus_tags = [] } -let locate lexbuf txt = - (txt, Loc.of_lexbuf lexbuf) +let locate source lexbuf txt = + (txt, Loc.of_lexbuf source lexbuf) + +let sublex lexer s = lexer (Lexing.from_string s) } let newline = ('\n' | '\r' | "\r\n") let space = [' ' '\t' '\012'] let space_or_esc_nl = (space | '\\' newline) +let sp = space_or_esc_nl let blank = newline | space let not_blank = [^' ' '\t' '\012' '\n' '\r'] let not_space_nor_comma = [^' ' '\t' '\012' ','] @@ -46,118 +51,122 @@ let tag = normal+ | ( normal+ ':' normal+ ) | normal+ '(' [^ ')' ]* ')' let variable = [ 'a'-'z' 'A'-'Z' '_' '-' '0'-'9' ]* let pattern = ([^ '(' ')' '\\' ] | '\\' [ '(' ')' ])* -rule ocamldep_output = parse - | ([^ ':' '\n' '\r' ]+ as k) ':' { let x = (k, space_sep_strings_nl lexbuf) in x :: ocamldep_output lexbuf } +rule ocamldep_output source = parse + | ([^ ':' '\n' '\r' ]+ as k) ':' { let x = (k, space_sep_strings_nl source lexbuf) in x :: ocamldep_output source lexbuf } | eof { [] } - | _ { error lexbuf "Expecting colon followed by space-separated module name list" } + | _ { error source lexbuf "Expecting colon followed by space-separated module name list" } -and space_sep_strings_nl = parse - | space* (not_blank+ as word) { word :: space_sep_strings_nl lexbuf } +and space_sep_strings_nl source = parse + | space* (not_blank+ as word) { word :: space_sep_strings_nl source lexbuf } | space* newline { Lexing.new_line lexbuf; [] } - | _ { error lexbuf "Expecting space-separated strings terminated with newline" } + | _ { error source lexbuf "Expecting space-separated strings terminated with newline" } -and space_sep_strings = parse - | space* (not_blank+ as word) { word :: space_sep_strings lexbuf } +and space_sep_strings source = parse + | space* (not_blank+ as word) { word :: space_sep_strings source lexbuf } | space* newline? eof { [] } - | _ { error lexbuf "Expecting space-separated strings" } + | _ { error source lexbuf "Expecting space-separated strings" } -and blank_sep_strings = parse - | blank* '#' not_newline* newline { blank_sep_strings lexbuf } +and blank_sep_strings source = parse + | blank* '#' not_newline* newline { blank_sep_strings source lexbuf } | blank* '#' not_newline* eof { [] } - | blank* (not_blank+ as word) { word :: blank_sep_strings lexbuf } + | blank* (not_blank+ as word) { word :: blank_sep_strings source lexbuf } | blank* eof { [] } - | _ { error lexbuf "Expecting blank-separated strings" } + | _ { error source lexbuf "Expecting blank-separated strings" } -and comma_sep_strings = parse +and comma_sep_strings source = parse | space* (not_space_nor_comma+ as word) space* eof { [word] } - | space* (not_space_nor_comma+ as word) { word :: comma_sep_strings_aux lexbuf } + | space* (not_space_nor_comma+ as word) { word :: comma_sep_strings_aux source lexbuf } | space* eof { [] } - | _ { error lexbuf "Expecting comma-separated strings (1)" } -and comma_sep_strings_aux = parse - | space* ',' space* (not_space_nor_comma+ as word) { word :: comma_sep_strings_aux lexbuf } + | _ { error source lexbuf "Expecting comma-separated strings (1)" } +and comma_sep_strings_aux source = parse + | space* ',' space* (not_space_nor_comma+ as word) { word :: comma_sep_strings_aux source lexbuf } | space* eof { [] } - | _ { error lexbuf "Expecting comma-separated strings (2)" } + | _ { error source lexbuf "Expecting comma-separated strings (2)" } -and comma_or_blank_sep_strings = parse +and comma_or_blank_sep_strings source = parse | space* (not_space_nor_comma+ as word) space* eof { [word] } - | space* (not_space_nor_comma+ as word) { word :: comma_or_blank_sep_strings_aux lexbuf } + | space* (not_space_nor_comma+ as word) { word :: comma_or_blank_sep_strings_aux source lexbuf } | space* eof { [] } - | _ { error lexbuf "Expecting (comma|blank)-separated strings (1)" } -and comma_or_blank_sep_strings_aux = parse - | space* ',' space* (not_space_nor_comma+ as word) { word :: comma_or_blank_sep_strings_aux lexbuf } - | space* (not_space_nor_comma+ as word) { word :: comma_or_blank_sep_strings_aux lexbuf } + | _ { error source lexbuf "Expecting (comma|blank)-separated strings (1)" } +and comma_or_blank_sep_strings_aux source = parse + | space* ',' space* (not_space_nor_comma+ as word) { word :: comma_or_blank_sep_strings_aux source lexbuf } + | space* (not_space_nor_comma+ as word) { word :: comma_or_blank_sep_strings_aux source lexbuf } | space* eof { [] } - | _ { error lexbuf "Expecting (comma|blank)-separated strings (2)" } + | _ { error source lexbuf "Expecting (comma|blank)-separated strings (2)" } -and parse_environment_path_w = parse - | ([^ ';']* as word) { word :: parse_environment_path_aux_w lexbuf } - | ';' ([^ ';']* as word) { "" :: word :: parse_environment_path_aux_w lexbuf } +and parse_environment_path_w source = parse + | ([^ ';']* as word) { word :: parse_environment_path_aux_w source lexbuf } + | ';' ([^ ';']* as word) { "" :: word :: parse_environment_path_aux_w source lexbuf } | eof { [] } -and parse_environment_path_aux_w = parse - | ';' ([^ ';']* as word) { word :: parse_environment_path_aux_w lexbuf } +and parse_environment_path_aux_w source = parse + | ';' ([^ ';']* as word) { word :: parse_environment_path_aux_w source lexbuf } | eof { [] } - | _ { error lexbuf "Impossible: expecting colon-separated strings" } + | _ { error source lexbuf "Impossible: expecting colon-separated strings" } -and parse_environment_path = parse - | ([^ ':']* as word) { word :: parse_environment_path_aux lexbuf } - | ':' ([^ ':']* as word) { "" :: word :: parse_environment_path_aux lexbuf } +and parse_environment_path source = parse + | ([^ ':']* as word) { word :: parse_environment_path_aux source lexbuf } + | ':' ([^ ':']* as word) { "" :: word :: parse_environment_path_aux source lexbuf } | eof { [] } -and parse_environment_path_aux = parse - | ':' ([^ ':']* as word) { word :: parse_environment_path_aux lexbuf } +and parse_environment_path_aux source = parse + | ':' ([^ ':']* as word) { word :: parse_environment_path_aux source lexbuf } | eof { [] } - | _ { error lexbuf "Impossible: expecting colon-separated strings" } + | _ { error source lexbuf "Impossible: expecting colon-separated strings" } -and conf_lines dir = parse - | space* '#' not_newline* newline { Lexing.new_line lexbuf; conf_lines dir lexbuf } +and conf_lines dir source = parse + | space* '#' not_newline* newline { Lexing.new_line lexbuf; conf_lines dir source lexbuf } | space* '#' not_newline* eof { [] } - | space* newline { Lexing.new_line lexbuf; conf_lines dir lexbuf } + | space* newline { Lexing.new_line lexbuf; conf_lines dir source lexbuf } | space* eof { [] } - | space* (not_newline_nor_colon+ as k) space* ':' space* + | space* (not_newline_nor_colon+ as k) (sp* as s1) ':' (sp* as s2) { let bexpr = try Glob.parse ?dir k - with exn -> error lexbuf "Invalid globbing pattern %S" k (Printexc.to_string exn) + with exn -> error source lexbuf "Invalid globbing pattern %S" k (Printexc.to_string exn) in - let v1 = conf_value empty lexbuf in - let v2 = conf_values v1 lexbuf in - Lexing.new_line lexbuf; (* FIXME values may have escaped newlines *) - let rest = conf_lines dir lexbuf in (bexpr,v2) :: rest + sublex (count_lines lexbuf) s1; sublex (count_lines lexbuf) s2; + let v1 = conf_value empty source lexbuf in + let v2 = conf_values v1 source lexbuf in + let rest = conf_lines dir source lexbuf in (bexpr,v2) :: rest } - | _ { error lexbuf "Invalid line syntax" } - -and conf_value x = parse - | '-' (tag as tag) { { (x) with minus_tags = locate lexbuf tag :: x.minus_tags } } - | '+'? (tag as tag) { { (x) with plus_tags = locate lexbuf tag :: x.plus_tags } } - | (_ | eof) { error lexbuf "Invalid tag modifier only '+ or '-' are allowed as prefix for tag" } - -and conf_values x = parse - | space_or_esc_nl* ',' space_or_esc_nl* { conf_values (conf_value x lexbuf) lexbuf } - | (newline | eof) { x } - | (_ | eof) { error lexbuf "Only ',' separated tags are alllowed" } - -and path_scheme patt_allowed = parse + | _ { error source lexbuf "Invalid line syntax" } + +and conf_value x source = parse + | '-' (tag as tag) { { (x) with minus_tags = locate source lexbuf tag :: x.minus_tags } } + | '+'? (tag as tag) { { (x) with plus_tags = locate source lexbuf tag :: x.plus_tags } } + | (_ | eof) { error source lexbuf "Invalid tag modifier only '+ or '-' are allowed as prefix for tag" } + +and conf_values x source = parse + | (sp* as s1) ',' (sp* as s2) { + sublex (count_lines lexbuf) s1; sublex (count_lines lexbuf) s2; + conf_values (conf_value x source lexbuf) source lexbuf + } + | newline { Lexing.new_line lexbuf; x } + | eof { x } + | _ { error source lexbuf "Only ',' separated tags are alllowed" } + +and path_scheme patt_allowed source = parse | ([^ '%' ]+ as prefix) - { `Word prefix :: path_scheme patt_allowed lexbuf } + { `Word prefix :: path_scheme patt_allowed source lexbuf } | "%(" (variable as var) ')' - { `Var (var, Bool.True) :: path_scheme patt_allowed lexbuf } + { `Var (var, Bool.True) :: path_scheme patt_allowed source lexbuf } | "%(" (variable as var) ':' (pattern as patt) ')' { if patt_allowed then let patt = My_std.String.implode (unescape (Lexing.from_string patt)) in - `Var (var, Glob.parse patt) :: path_scheme patt_allowed lexbuf + `Var (var, Glob.parse patt) :: path_scheme patt_allowed source lexbuf else - error lexbuf "Patterns are not allowed in this pathname (%%(%s:%s) only in ~prod)" var patt } + error source lexbuf "Patterns are not allowed in this pathname (%%(%s:%s) only in ~prod)" var patt } | '%' - { `Var ("", Bool.True) :: path_scheme patt_allowed lexbuf } + { `Var ("", Bool.True) :: path_scheme patt_allowed source lexbuf } | eof { [] } - | _ { error lexbuf "Bad pathanme scheme" } + | _ { error source lexbuf "Bad pathanme scheme" } and unescape = parse | '\\' (['(' ')'] as c) { c :: unescape lexbuf } | _ as c { c :: unescape lexbuf } | eof { [] } -and ocamlfind_query = parse +and ocamlfind_query source = parse | newline* "package:" space* (not_newline* as n) newline+ "description:" space* (not_newline* as d) newline+ @@ -166,11 +175,17 @@ and ocamlfind_query = parse "linkopts:" space* (not_newline* as lo) newline+ "location:" space* (not_newline* as l) newline+ { n, d, v, a, lo, l } - | _ { error lexbuf "Bad ocamlfind query" } + | _ { error source lexbuf "Bad ocamlfind query" } -and trim_blanks = parse +and trim_blanks source = parse | blank* (not_blank* as word) blank* { word } - | _ { error lexbuf "Bad input for trim_blanks" } + | _ { error source lexbuf "Bad input for trim_blanks" } -and tag_gen = parse +and tag_gen source = parse | (normal+ as name) ('(' ([^')']* as param) ')')? { name, param } + | _ { error source lexbuf "Not a valid parametrized tag" } + +and count_lines lb = parse + | space* { count_lines lb lexbuf } + | '\\' newline { Lexing.new_line lb; count_lines lb lexbuf } + | eof { () } diff --git a/ocamlbuild/loc.ml b/ocamlbuild/loc.ml index 2bf3900e81..7a324c1618 100644 --- a/ocamlbuild/loc.ml +++ b/ocamlbuild/loc.ml @@ -4,26 +4,31 @@ open Lexing -type location = position * position +(* We use a loosely structural type so that this bit of code can be + easily reused by project that would wish it, without introducing + any type-compatibility burden. *) +type source = string (* "file", "environment variable", "command-line option" ... *) +type location = source * position * position let file loc = loc.pos_fname let line loc = loc.pos_lnum let char loc = loc.pos_cnum - loc.pos_bol -let print_loc ppf (start, end_) = +let print_loc ppf (source, start, end_) = let open Format in let print one_or_two ppf (start_num, end_num) = if one_or_two then fprintf ppf " %d" start_num else fprintf ppf "s %d-%d" start_num end_num in - fprintf ppf "File %S, line%a, character%a:@." + fprintf ppf "%s %S, line%a, character%a:@." + (String.capitalize source) (file start) (print (line start = line end_)) (line start, line end_) (print (line start = line end_ && char start = char end_)) (char start, char end_) -let of_lexbuf lexbuf = - (lexbuf.lex_start_p, lexbuf.lex_curr_p) +let of_lexbuf source lexbuf = + (source, lexbuf.lex_start_p, lexbuf.lex_curr_p) let print_loc_option ppf = function | None -> () diff --git a/ocamlbuild/loc.mli b/ocamlbuild/loc.mli index 9ed842ef2d..c5768bc1ce 100644 --- a/ocamlbuild/loc.mli +++ b/ocamlbuild/loc.mli @@ -1,6 +1,7 @@ -type location = Lexing.position * Lexing.position +type source = string +type location = source * Lexing.position * Lexing.position val print_loc : Format.formatter -> location -> unit val print_loc_option : Format.formatter -> location option -> unit -val of_lexbuf : Lexing.lexbuf -> location +val of_lexbuf : source -> Lexing.lexbuf -> location diff --git a/ocamlbuild/log.ml b/ocamlbuild/log.ml index 380c9a59a9..d50969e341 100644 --- a/ocamlbuild/log.ml +++ b/ocamlbuild/log.ml @@ -48,7 +48,31 @@ let update () = Display.update !-internal_display let event ?pretend x = Display.event !-internal_display ?pretend x let display x = Display.display !-internal_display x +let do_at_end = Queue.create () +let already_asked = Hashtbl.create 10 + +let at_end_always ~name thunk = + if not (Hashtbl.mem already_asked name) then begin + Hashtbl.add already_asked name (); + Queue.add thunk do_at_end; + end + +let at_end ~name thunk = at_end_always ~name (function + | `Quiet -> () + | `Success | `Error -> thunk `Error) +let at_failure ~name thunk = at_end_always ~name (function + | `Success | `Quiet -> () + | `Error -> thunk `Error) + let finish ?how () = + while not (Queue.is_empty do_at_end) do + let actions = Queue.copy do_at_end in + Queue.clear do_at_end; + (* calling a thunk may add new actions again, hence the loop *) + Queue.iter (fun thunk -> + thunk (match how with None -> `Quiet | Some how -> how) + ) actions; + done; match !internal_display with | None -> () | Some d -> Display.finish ?how d diff --git a/ocamlbuild/log.mli b/ocamlbuild/log.mli index a414608a6e..413a476dd5 100644 --- a/ocamlbuild/log.mli +++ b/ocamlbuild/log.mli @@ -32,3 +32,13 @@ val finish : ?how:[`Success|`Error|`Quiet] -> unit -> unit val display : (out_channel -> unit) -> unit val update : unit -> unit val mode : string -> bool + +(** Wrap logging event so that only fire at the end of the compilation + process, possibly depending on the termination status. + + The name is used to avoid printing the same hint/warning twice, + even if [at_end] is called several times. Use different names for + distinct events. +*) +val at_end : name:string -> ([> `Error | `Quiet ] -> unit) -> unit +val at_failure : name:string -> ([> `Error ] -> unit) -> unit diff --git a/ocamlbuild/main.ml b/ocamlbuild/main.ml index 7413a7a7f6..07ca9c0652 100644 --- a/ocamlbuild/main.ml +++ b/ocamlbuild/main.ml @@ -81,7 +81,7 @@ let proceed () = let target_dirs = List.union [] (List.map Pathname.dirname !Options.targets) in - Configuration.parse_string + Configuration.parse_string ~source:Const.Source.builtin "<**/*.ml> or <**/*.mli> or <**/*.mlpack> or <**/*.ml.depends>: ocaml\n\ <**/*.byte>: ocaml, byte, program\n\ <**/*.odoc>: ocaml, doc\n\ @@ -93,16 +93,21 @@ let proceed () = <**/*.cmx>: ocaml, native\n\ "; + List.iter + (Configuration.parse_string ~source:Const.Source.command_line) + !Options.tag_lines; + Configuration.tag_any !Options.tags; - if !Options.recursive - || Sys.file_exists (* authorized since we're not in build *) "_tags" - || Sys.file_exists (* authorized since we're not in build *) "myocamlbuild.ml" + if !Options.recursive || Options.ocamlbuild_project_heuristic () then Configuration.tag_any ["traverse"]; (* options related to findlib *) - List.iter - (fun pkg -> Configuration.tag_any [Param_tags.make "package" pkg]) - !Options.ocaml_pkgs; + if !Options.use_ocamlfind then + List.iter + (fun pkg -> + let tag = Param_tags.make "package" pkg in + Configuration.tag_any [tag]) + !Options.ocaml_pkgs; begin match !Options.ocaml_syntax with | Some syntax -> Configuration.tag_any [Param_tags.make "syntax" syntax] @@ -173,8 +178,6 @@ let proceed () = dprintf 3 "include directories are:@ %a" print_string_list !Options.include_dirs; Options.entry := Some entry; - List.iter Configuration.parse_string !Options.tag_lines; - Hooks.call_hook Hooks.Before_rules; Ocaml_specific.init (); Hooks.call_hook Hooks.After_rules; diff --git a/ocamlbuild/my_std.ml b/ocamlbuild/my_std.ml index c283987cc2..4dce7a0cfe 100644 --- a/ocamlbuild/my_std.ml +++ b/ocamlbuild/my_std.ml @@ -410,3 +410,22 @@ let memo3 f = with Not_found -> let res = f x y z in (Hashtbl.add cache (x,y,z) res; res) + +let set_lexbuf_fname fname lexbuf = + let open Lexing in + lexbuf.lex_start_p <- { lexbuf.lex_start_p with pos_fname = fname }; + lexbuf.lex_curr_p <- { lexbuf.lex_curr_p with pos_fname = fname }; + () + +let lexbuf_of_string ?name content = + let lexbuf = Lexing.from_string content in + let fname = match name with + | Some name -> name + | None -> + (* 40: hope the location will fit one line of 80 chars *) + if String.length content < 40 && not (String.contains content '\n') then + String.escaped content + else "" + in + set_lexbuf_fname fname lexbuf; + lexbuf diff --git a/ocamlbuild/my_std.mli b/ocamlbuild/my_std.mli index 403c4e9616..d7e146370f 100644 --- a/ocamlbuild/my_std.mli +++ b/ocamlbuild/my_std.mli @@ -62,3 +62,6 @@ val filename_concat : string -> string -> string val invalid_arg' : ('a, Format.formatter, unit, 'b) format4 -> 'a include Signatures.MISC + +val set_lexbuf_fname : string -> Lexing.lexbuf -> unit +val lexbuf_of_string : ?name:string -> string -> Lexing.lexbuf diff --git a/ocamlbuild/ocaml_compiler.ml b/ocamlbuild/ocaml_compiler.ml index e21618ee0c..c270a7f637 100644 --- a/ocamlbuild/ocaml_compiler.ml +++ b/ocamlbuild/ocaml_compiler.ml @@ -116,10 +116,30 @@ let prepare_compile build ml = match mandatory, res with | _, Good _ -> () | `mandatory, Bad exn -> - if !Options.ignore_auto then - dprintf 3 "Warning: Failed to build the module \ - %s requested by ocamldep" name - else raise exn + if not !Options.ignore_auto then raise exn; + dprintf 3 + "Warning: Failed to build the module %s requested by ocamldep." + name; + if not (!Options.recursive || Options.ocamlbuild_project_heuristic ()) + then Log.at_failure ~name:"a module failed to build, + while recursive traversal was disabled by fragile heuristic; + hint that having a _tags or myocamlbuild.ml would maybe solve + the build error" + (fun `Error -> + eprintf "Hint:@ Recursive@ traversal@ of@ subdirectories@ \ + was@ not@ enabled@ for@ this@ build,@ as@ the@ working@ \ + directory does@ not@ look@ like@ an@ ocamlbuild@ project@ \ + (no@ '_tags'@ or@ 'myocamlbuild.ml'@ file).@ \ + If@ you@ have@ modules@ in@ subdirectories,@ you@ should@ add@ \ + the@ option@ \"-r\"@ or@ create@ an@ empty@ '_tags'@ file.@\n\ + @\n\ + To@ enable@ recursive@ traversal@ for@ some@ subdirectories@ \ + only,@ you@ can@ use@ the@ following@ '_tags'@ file:@\n\ + @[<v 4>@,\ + true: -traverse@,\ + <dir1> or <dir2>: traverse@,\ + @]" + ); | `just_try, Bad _ -> () end modules results diff --git a/ocamlbuild/ocaml_specific.ml b/ocamlbuild/ocaml_specific.ml index 43605d361e..134a153325 100644 --- a/ocamlbuild/ocaml_specific.ml +++ b/ocamlbuild/ocaml_specific.ml @@ -598,18 +598,22 @@ let () = (fun param -> S [A "-for-pack"; A param]); pflag ["ocaml"; "native"; "compile"] "inline" (fun param -> S [A "-inline"; A param]); - pflag ["ocaml"; "compile"] "pp" - (fun param -> S [A "-pp"; A param]); - pflag ["ocaml"; "ocamldep"] "pp" - (fun param -> S [A "-pp"; A param]); - pflag ["ocaml"; "doc"] "pp" - (fun param -> S [A "-pp"; A param]); - pflag ["ocaml"; "infer_interface"] "pp" - (fun param -> S [A "-pp"; A param]); + List.iter (fun pp -> + pflag ["ocaml"; "compile"] pp + (fun param -> S [A ("-" ^ pp); A param]); + pflag ["ocaml"; "ocamldep"] pp + (fun param -> S [A ("-" ^ pp); A param]); + pflag ["ocaml"; "doc"] pp + (fun param -> S [A ("-" ^ pp); A param]); + pflag ["ocaml"; "infer_interface"] pp + (fun param -> S [A ("-" ^ pp); A param]) + ) ["pp"; "ppx"]; pflag ["ocaml";"compile";] "warn" (fun param -> S [A "-w"; A param]); pflag ["ocaml";"compile";] "warn_error" (fun param -> S [A "-warn-error"; A param]); + pflag ["ocaml"; "compile"] "open" + (fun param -> S [A "-open"; A param]); () let camlp4_flags camlp4s = @@ -683,6 +687,14 @@ flag ["ocaml"; "link"; "program"; "custom"; "byte"] (A "-custom");; flag ["ocaml"; "link"; "library"; "custom"; "byte"] (A "-custom");; flag ["ocaml"; "compile"; "profile"; "native"] (A "-p");; flag ["ocaml"; "compile"; "no_alias_deps";] (A "-no-alias-deps");; +flag ["ocaml"; "compile"; "strict_formats";] (A "-strict-formats");; +flag ["ocaml"; "native"; "compile"; "opaque";] (A "-opaque");; +flag ["ocaml"; "native"; "compile"; "no_float_const_prop";] (A "-no-float-const-prop"); +flag ["ocaml"; "compile"; "keep_locs";] (A "-keep-locs"); +flag ["ocaml"; "absname"; "compile"] (A "-absname");; +flag ["ocaml"; "absname"; "infer_interface"] (A "-absname");; +flag ["ocaml"; "byte"; "compile"; "compat_32";] (A "-compat-32"); + (* threads, with or without findlib *) flag ["ocaml"; "compile"; "thread"] (A "-thread");; diff --git a/ocamlbuild/ocaml_utils.ml b/ocamlbuild/ocaml_utils.ml index 5927696372..409f0a0694 100644 --- a/ocamlbuild/ocaml_utils.ml +++ b/ocamlbuild/ocaml_utils.ml @@ -80,7 +80,8 @@ let expand_module = let string_list_of_file file = with_input_file file begin fun ic -> - Lexers.blank_sep_strings (Lexing.from_channel ic) + Lexers.blank_sep_strings + Const.Source.file (Lexing.from_channel ic) end let print_path_list = Pathname.print_path_list @@ -149,7 +150,8 @@ let read_path_dependencies = let depends = path-.-"depends" in with_input_file depends begin fun ic -> let ocamldep_output = - try Lexers.ocamldep_output (Lexing.from_channel ic) + try Lexers.ocamldep_output + Const.Source.ocamldep (Lexing.from_channel ic) with Lexers.Error (msg,_) -> raise (Ocamldep_error(Printf.sprintf "Ocamldep.ocamldep: bad output (%s)" msg)) in let deps = List.fold_right begin fun (path, deps) acc -> diff --git a/ocamlbuild/ocamlbuild_pack.mlpack b/ocamlbuild/ocamlbuild_pack.mlpack index 83f1065f47..450592f539 100644 --- a/ocamlbuild/ocamlbuild_pack.mlpack +++ b/ocamlbuild/ocamlbuild_pack.mlpack @@ -1,3 +1,4 @@ +Const Loc Log My_unix diff --git a/ocamlbuild/options.ml b/ocamlbuild/options.ml index 68c0ac85db..5ee512200f 100644 --- a/ocamlbuild/options.ml +++ b/ocamlbuild/options.ml @@ -23,6 +23,7 @@ open Format open Command let entry = ref None +let project_root_dir = ref None let build_dir = ref (Filename.concat (Sys.getcwd ()) "_build") let include_dirs = ref [] let exclude_dirs = ref [] @@ -141,7 +142,8 @@ let use_jocaml () = ;; let add_to rxs x = - let xs = Lexers.comma_or_blank_sep_strings (Lexing.from_string x) in + let xs = Lexers.comma_or_blank_sep_strings + Const.Source.command_line (Lexing.from_string x) in rxs := xs :: !rxs let add_to' rxs x = if x <> dummy then @@ -217,8 +219,10 @@ let spec = ref ( "-classic-display", Set Log.classic_display, " Display executed commands the old-fashioned way"; "-use-menhir", Set use_menhir, " Use menhir instead of ocamlyacc"; "-use-jocaml", Unit use_jocaml, " Use jocaml compilers instead of ocaml ones"; - "-use-ocamlfind", Set use_ocamlfind, " Option deprecated. Now enabled by default. Use -no-ocamlfind to disable"; - "-no-ocamlfind", Clear use_ocamlfind, " Don't use ocamlfind"; + "-use-ocamlfind", Set use_ocamlfind, " Use the 'ocamlfind' wrapper instead of \ + using Findlib directly to determine command-line arguments. \ + Use -no-ocamlfind to disable."; + "-no-ocamlfind", Clear use_ocamlfind, " Don't use ocamlfind."; "-j", Set_int Command.jobs, "<N> Allow N jobs at once (0 for unlimited)"; @@ -270,6 +274,8 @@ let init () = parse_argv argv' !spec anon_fun usage_msg; Shell.mkdir_p !build_dir; + project_root_dir := Some (Sys.getcwd ()); + let () = let log = !log_file_internal in if log = "" then Log.init None @@ -285,18 +291,33 @@ let init () = in if !use_ocamlfind then begin - ocamlfind_cmd := A "ocamlfind"; - let cmd = Command.string_of_command_spec !ocamlfind_cmd in - begin try ignore(Command.search_in_path cmd) - with Not_found -> failwith "ocamlfind not found on path, but -no-ocamlfind not used" end; - (* TODO: warning message when using an option such as -ocamlc *) + begin try ignore(Command.search_in_path "ocamlfind") + with Not_found -> + failwith "ocamlfind not found on path, but -no-ocamlfind not used" + end; + + let with_ocamlfind (command_name, command_ref) = + command_ref := match !command_ref with + | Sh user_command -> + (* this command has been set by the user + using an -ocamlc, -ocamlopt, etc. flag; + + not all such combinations make sense (eg. "ocamlfind + /my/special/path/to/ocamlc" will make ocamlfind choke), + but the user will see the error and hopefully fix the + flags. *) + ocamlfind & (Sh user_command); + | _ -> ocamlfind & A command_name + in (* Note that plugins can still modify these variables After_options. This design decision can easily be changed. *) - ocamlc := ocamlfind & A"ocamlc"; - ocamlopt := ocamlfind & A"ocamlopt"; - ocamldep := ocamlfind & A"ocamldep"; - ocamldoc := ocamlfind & A"ocamldoc"; - ocamlmktop := ocamlfind & A"ocamlmktop"; + List.iter with_ocamlfind [ + "ocamlc", ocamlc; + "ocamlopt", ocamlopt; + "ocamldep", ocamldep; + "ocamldoc", ocamldoc; + "ocamlmktop", ocamlmktop; + ] end; let reorder x y = x := !x @ (List.concat (List.rev !y)) in @@ -334,3 +355,17 @@ let init () = ignore_list := List.map String.capitalize !ignore_list ;; + +(* The current heuristic: we know we are in an ocamlbuild project if + either _tags or myocamlbuild.ml are present at the root. This + heuristic has been documented and explained to users, so it should + not be changed. *) +let ocamlbuild_project_heuristic () = + let root_dir = match !project_root_dir with + | None -> Sys.getcwd () + | Some dir -> dir in + let at_root file = Filename.concat root_dir file in + Sys.file_exists (* authorized since we're not in build *) + (at_root "_tags") + || Sys.file_exists (* authorized since we're not in build *) + (at_root "myocamlbuild.ml") diff --git a/ocamlbuild/options.mli b/ocamlbuild/options.mli index b450c84513..0a0d39c4bc 100644 --- a/ocamlbuild/options.mli +++ b/ocamlbuild/options.mli @@ -15,12 +15,20 @@ include Signatures.OPTIONS with type command_spec = Command.spec -(* this option is not in Signatures.OPTIONS yet because adding tags to +(* This option is not in Signatures.OPTIONS yet because adding tags to the compilation of the plugin is a recent feature that may still be subject to change, so the interface may not be stable; besides, there is obviously little to gain from tweaking that option from inside the plugin itself... *) val plugin_tags : string list ref +(* Returns 'true' if we heuristically infer that we are run from an + ocamlbuild projet (either _tags or myocamlbuild.ml are present). + + This information is used to decide whether to enable recursive + traversal of subdirectories by default. +*) +val ocamlbuild_project_heuristic : unit -> bool + val entry : bool Slurp.entry option ref val init : unit -> unit diff --git a/ocamlbuild/param_tags.ml b/ocamlbuild/param_tags.ml index 1ccccc6040..456239031d 100644 --- a/ocamlbuild/param_tags.ml +++ b/ocamlbuild/param_tags.ml @@ -10,6 +10,7 @@ (* *) (***********************************************************************) +open My_std (* Original author: Romain Bardou *) @@ -32,10 +33,10 @@ let only_once f = let declare name action = Hashtbl.add declared_tags name (only_once action) -let parse tag = Lexers.tag_gen (Lexing.from_string tag) +let parse source tag = Lexers.tag_gen source (lexbuf_of_string tag) -let acknowledge maybe_loc tag = - acknowledged_tags := (parse tag, maybe_loc) :: !acknowledged_tags +let acknowledge source maybe_loc tag = + acknowledged_tags := (parse source tag, maybe_loc) :: !acknowledged_tags let really_acknowledge ?(quiet=false) ((name, param), maybe_loc) = match param with @@ -51,8 +52,9 @@ let really_acknowledge ?(quiet=false) ((name, param), maybe_loc) = Loc.print_loc_option maybe_loc name param; List.iter (fun f -> f param) actions -let partial_init ?quiet tags = - Tags.iter (fun tag -> really_acknowledge ?quiet (parse tag, None)) tags +let partial_init ?quiet source tags = + let parse_noloc tag = (parse source tag, None) in + Tags.iter (fun tag -> really_acknowledge ?quiet (parse_noloc tag)) tags let init () = List.iter really_acknowledge (My_std.List.ordered_unique !acknowledged_tags) diff --git a/ocamlbuild/param_tags.mli b/ocamlbuild/param_tags.mli index 22c081256e..0611394135 100644 --- a/ocamlbuild/param_tags.mli +++ b/ocamlbuild/param_tags.mli @@ -22,7 +22,7 @@ if a tag of the form [name(param)] is [acknowledge]d. A given tag may be declared several times with different actions. All actions will be executed, in the order they were declared. *) -val acknowledge: Loc.location option -> string -> unit +val acknowledge: Loc.source -> Loc.location option -> string -> unit (** Acknowledge a tag. If the tag is of the form [X(Y)], and have been declared using [declare], @@ -37,7 +37,7 @@ This will make effective all instantiations [foo(bar)] such that the parametrized tag [foo] has been [declare]d and [foo(bar)] has been [acknowledge]d after the last [init] call. *) -val partial_init: ?quiet:bool -> Tags.t -> unit +val partial_init: ?quiet:bool -> Loc.source -> Tags.t -> unit (** Initialize a list of tags This will make effective the instances [foo(bar)] appearing diff --git a/ocamlbuild/plugin.ml b/ocamlbuild/plugin.ml index eb831e7223..e4d18363d1 100644 --- a/ocamlbuild/plugin.ml +++ b/ocamlbuild/plugin.ml @@ -202,7 +202,7 @@ module Make(U:sig end) = precisely those that will be used during the compilation of the plugin, and no more. *) - Param_tags.partial_init plugin_tags; + Param_tags.partial_init Const.Source.plugin_tag plugin_tags; let cmd = (* The argument order is important: we carefully put the diff --git a/ocamlbuild/resource.ml b/ocamlbuild/resource.ml index 4121d194af..229d771297 100644 --- a/ocamlbuild/resource.ml +++ b/ocamlbuild/resource.ml @@ -17,6 +17,8 @@ open Format open Log open Pathname.Operators + +type t = Pathname.t module Resources = Set.Make(Pathname) let print = Pathname.print @@ -312,7 +314,8 @@ end = struct let mk (pattern_allowed, s) = List.map begin function | `Var(var_name, globber) -> V(var_name, globber) | `Word s -> A s - end (Lexers.path_scheme pattern_allowed (Lexing.from_string s)) + end (Lexers.path_scheme pattern_allowed + Const.Source.target_pattern (lexbuf_of_string s)) let mk = memo mk diff --git a/ocamlbuild/resource.mli b/ocamlbuild/resource.mli index 0ec15d36e7..eb75d3db98 100644 --- a/ocamlbuild/resource.mli +++ b/ocamlbuild/resource.mli @@ -18,6 +18,7 @@ open Pathname type resource_pattern type env +type t = Pathname.t module Resources : Set.S with type elt = t module Cache : diff --git a/ocamlbuild/testsuite/findlibonly.ml b/ocamlbuild/testsuite/findlibonly.ml index 7be8b0fddf..d159ad47b4 100644 --- a/ocamlbuild/testsuite/findlibonly.ml +++ b/ocamlbuild/testsuite/findlibonly.ml @@ -32,4 +32,11 @@ let () = test "PredicateFlag" ~matching:[_build [M.f "test.ml.depends"]] ~targets:("test.ml.depends", []) ();; +let () = test "ToolsFlagsConflict" + ~description:"PR#6300: conflicts between -ocamlc and -use-ocamlfind options" + ~options:[`use_ocamlfind; `ocamlc "\"ocamlc -annot\""] + ~tree:[T.f "test.ml" ~content:"let x = 1"] + ~matching:[_build [M.f "test.annot"; M.f "test.byte"]] + ~targets:("test.byte", []) ();; + run ~root:"_test_findlibonly";; diff --git a/ocamlbuild/testsuite/internal.ml b/ocamlbuild/testsuite/internal.ml index 2a12070f95..fc7ff98dd3 100644 --- a/ocamlbuild/testsuite/internal.ml +++ b/ocamlbuild/testsuite/internal.ml @@ -162,7 +162,7 @@ let () = test "OutputObj" let () = test "StrictSequenceFlag" ~options:[`no_ocamlfind; `quiet] - ~description:"-strict_sequence tag" + ~description:"strict_sequence tag" ~tree:[T.f "hello.ml" ~content:"let () = 1; ()"; T.f "_tags" ~content:"true: strict_sequence\n"] ~failing_msg:"File \"hello.ml\", line 1, characters 9-10: @@ -170,6 +170,17 @@ Error: This expression has type int but an expression was expected of type unit\nCommand exited with code 2." ~targets:("hello.byte",[]) ();; +let () = test "StrictFormatsFlag" + ~options:[`no_ocamlfind; `quiet] + ~description:"strict_format tag" + ~tree:[T.f "hello.ml" ~content:"let _ = Printf.printf \"%.10s\""; + T.f "_tags" ~content:"true: strict_formats\n"] + ~failing_msg:"File \"hello.ml\", line 1, characters 22-29: +Error: invalid format \"%.10s\": at character number 0, \ +`precision' is incompatible with 's' in sub-format \"%.10s\" +Command exited with code 2." + ~targets:("hello.byte",[]) ();; + let () = test "PrincipalFlag" ~options:[`no_ocamlfind; `quiet] ~description:"-principal tag" @@ -264,4 +275,32 @@ let () = test "TagsInNonHygienic" ~matching:[M.f "main.byte"] ~targets:("main.byte",[]) ();; +let () = test "TagsNewlines" + ~description:"Regression test for PR#6087 about placement \ + of newline-escaping backslashes" + ~options:[`no_ocamlfind] + ~tree:[ + T.f "main.ml" ~content:""; + T.f "_tags" ~content: +"<foo>: debug,\\ +rectypes +<bar>: \\ +debug, rectypes +<baz>\\ +: debug, rectypes +"; + ] + ~matching:[M.f "main.byte"] + ~targets:("main.byte",[]) ();; + +let () = test "OpenTag" + ~description:"Test the parametrized tag for the new -open feature" + ~options:[`no_ocamlfind] + ~tree:[ + T.f "test.ml" ~content:"let _ = map rev [ []; [3;2] ]"; + T.f "_tags" ~content: "<test.*>: open(List)"; + ] + ~matching:[M.f "test.byte"] + ~targets:("test.byte",[]) ();; + run ~root:"_test_internal";; diff --git a/ocamldoc/.depend b/ocamldoc/.depend index c2965f6a30..0f692a22c6 100644 --- a/ocamldoc/.depend +++ b/ocamldoc/.depend @@ -182,14 +182,16 @@ odoc_sig.cmo : ../typing/types.cmi ../typing/typedtree.cmi \ odoc_misc.cmi odoc_messages.cmo odoc_merge.cmi odoc_global.cmi \ odoc_extension.cmo odoc_exception.cmo odoc_env.cmi odoc_class.cmo \ ../utils/misc.cmi ../parsing/location.cmi ../typing/ident.cmi \ - ../typing/btype.cmi ../parsing/asttypes.cmi odoc_sig.cmi + ../typing/ctype.cmi ../typing/btype.cmi ../parsing/asttypes.cmi \ + odoc_sig.cmi odoc_sig.cmx : ../typing/types.cmx ../typing/typedtree.cmx \ ../typing/path.cmx ../parsing/parsetree.cmi odoc_value.cmx odoc_types.cmx \ odoc_type.cmx odoc_parameter.cmx odoc_name.cmx odoc_module.cmx \ odoc_misc.cmx odoc_messages.cmx odoc_merge.cmx odoc_global.cmx \ odoc_extension.cmx odoc_exception.cmx odoc_env.cmx odoc_class.cmx \ ../utils/misc.cmx ../parsing/location.cmx ../typing/ident.cmx \ - ../typing/btype.cmx ../parsing/asttypes.cmi odoc_sig.cmi + ../typing/ctype.cmx ../typing/btype.cmx ../parsing/asttypes.cmi \ + odoc_sig.cmi odoc_str.cmo : ../typing/types.cmi ../typing/printtyp.cmi odoc_value.cmo \ odoc_type.cmo odoc_print.cmi odoc_name.cmi odoc_misc.cmi \ odoc_messages.cmo odoc_extension.cmo odoc_exception.cmo odoc_class.cmo \ diff --git a/ocamldoc/Makefile b/ocamldoc/Makefile index 564a26bfd9..0e8b288b85 100644 --- a/ocamldoc/Makefile +++ b/ocamldoc/Makefile @@ -172,14 +172,20 @@ debug: $(MAKE) OCAMLPP="" $(OCAMLDOC): $(EXECMOFILES) - $(OCAMLC) -o $@ -linkall unix.cma str.cma dynlink.cma $(OCAMLSRCDIR)/compilerlibs/ocamlcommon.cma $(LINKFLAGS) $(OCAMLCMOFILES) $(EXECMOFILES) + $(OCAMLC) -o $@ -linkall unix.cma str.cma dynlink.cma \ + $(OCAMLSRCDIR)/compilerlibs/ocamlcommon.cma \ + $(LINKFLAGS) $(OCAMLCMOFILES) $(EXECMOFILES) $(OCAMLDOC_OPT): $(EXECMXFILES) - $(OCAMLOPT) -o $@ -linkall unix.cmxa str.cmxa dynlink.cmxa $(OCAMLSRCDIR)/compilerlibs/ocamlcommon.cmxa $(LINKFLAGS) $(OCAMLCMXFILES) $(EXECMXFILES) + $(OCAMLOPT) -o $@ -linkall unix.cmxa str.cmxa dynlink.cmxa \ + $(OCAMLSRCDIR)/compilerlibs/ocamlcommon.cmxa \ + $(LINKFLAGS) $(OCAMLCMXFILES) $(EXECMXFILES) $(OCAMLDOC_LIBCMA): $(LIBCMOFILES) - $(OCAMLC) -a -o $@ $(LINKFLAGS) $(OCAMLSRCDIR)/tools/depend.cmo $(LIBCMOFILES) + $(OCAMLC) -a -o $@ $(LINKFLAGS) $(OCAMLSRCDIR)/tools/depend.cmo \ + $(LIBCMOFILES) $(OCAMLDOC_LIBCMXA): $(LIBCMXFILES) - $(OCAMLOPT) -a -o $@ $(LINKFLAGS) $(OCAMLSRCDIR)/tools/depend.cmx $(LIBCMXFILES) + $(OCAMLOPT) -a -o $@ $(LINKFLAGS) $(OCAMLSRCDIR)/tools/depend.cmx \ + $(LIBCMXFILES) manpages: stdlib_man/Pervasives.3o html_doc: stdlib_html/Pervasives.html @@ -244,7 +250,7 @@ install: dummy if test -d stdlib_man; then $(CP) stdlib_man/* $(INSTALL_MANODIR); else : ; fi installopt: - if test -f $(OCAMLDOC_OPT) ; then $(MAKE) installopt_really ; fi + if test -f $(OCAMLDOC_OPT); then $(MAKE) installopt_really ; fi installopt_really: if test -d $(INSTALL_BINDIR); then : ; else $(MKDIR) $(INSTALL_BINDIR); fi diff --git a/ocamldoc/Makefile.nt b/ocamldoc/Makefile.nt index 591c194602..22cd36eb03 100644 --- a/ocamldoc/Makefile.nt +++ b/ocamldoc/Makefile.nt @@ -21,8 +21,8 @@ OCAMLOPT = $(OCAMLRUN) $(ROOTDIR)/ocamlopt -nostdlib -I $(ROOTDIR)/stdlib OCAMLDEP = $(OCAMLRUN) $(ROOTDIR)/tools/ocamldep OCAMLLEX = $(OCAMLRUN) $(ROOTDIR)/boot/ocamllex OCAMLYACC = $(ROOTDIR)/yacc/ocamlyacc -OCAMLLIB = $(LIBDIR) -OCAMLBIN = $(BINDIR) +OCAMLLIB = $(LIBDIR) +OCAMLBIN = $(BINDIR) OCAMLPP=-pp "grep -v DEBUG" @@ -58,13 +58,13 @@ INCLUDES_DEP=-I $(OCAMLSRCDIR)/parsing \ INCLUDES_NODEP= -I $(OCAMLSRCDIR)/stdlib \ -I $(OCAMLSRCDIR)/otherlibs/str \ -I $(OCAMLSRCDIR)/otherlibs/dynlink \ - -I $(OCAMLSRCDIR)/otherlibs/win32unix \ + -I $(OCAMLSRCDIR)/otherlibs/$(UNIXLIB) \ -I $(OCAMLSRCDIR)/otherlibs/num \ - -I $(OCAMLSRCDIR)/otherlibs/win32graph + -I $(OCAMLSRCDIR)/otherlibs/$(GRAPHLIB) INCLUDES=$(INCLUDES_DEP) $(INCLUDES_NODEP) -COMPFLAGS=$(INCLUDES) -warn-error A +COMPFLAGS=$(INCLUDES) -warn-error A -safe-string LINKFLAGS=$(INCLUDES) -nostdlib CMOFILES= odoc_config.cmo \ @@ -121,7 +121,6 @@ EXECMOFILES=$(CMOFILES) \ odoc_args.cmo \ odoc.cmo - EXECMXFILES= $(EXECMOFILES:.cmo=.cmx) EXECMIFILES= $(EXECMOFILES:.cmo=.cmi) @@ -135,25 +134,35 @@ OCAMLCMOFILES= \ OCAMLCMXFILES=$(OCAMLCMOFILES:.cmo=.cmx) -all: exe lib +all: + $(MAKEREC) exe + $(MAKEREC) lib + exe: $(OCAMLDOC) lib: $(OCAMLDOC_LIBCMA) $(OCAMLDOC_LIBCMI) opt.opt: exeopt libopt exeopt: $(OCAMLDOC_OPT) libopt: $(OCAMLDOC_LIBCMXA) $(OCAMLDOC_LIBCMI) + debug: - $(MAKE) OCAMLPP="" + $(MAKEREC) OCAMLPP="" $(OCAMLDOC): $(EXECMOFILES) - $(OCAMLC) -o $@ -linkall unix.cma str.cma dynlink.cma $(OCAMLSRCDIR)/compilerlibs/ocamlcommon.cma $(LINKFLAGS) $(OCAMLCMOFILES) $(EXECMOFILES) + $(OCAMLC) -o $@ -linkall unix.cma str.cma dynlink.cma \ + $(OCAMLSRCDIR)/compilerlibs/ocamlcommon.cma \ + $(LINKFLAGS) $(OCAMLCMOFILES) $(EXECMOFILES) $(OCAMLDOC_OPT): $(EXECMXFILES) - $(OCAMLOPT) -o $@ unix.cmxa str.cmxa dynlink.cmxa $(OCAMLSRCDIR)/compilerlibs/ocamlcommon.cmxa $(LINKFLAGS) $(OCAMLCMXFILES) $(EXECMXFILES) + $(OCAMLOPT) -o $@ -linkall unix.cmxa str.cmxa dynlink.cmxa \ + $(OCAMLSRCDIR)/compilerlibs/ocamlcommon.cmxa \ + $(LINKFLAGS) $(OCAMLCMXFILES) $(EXECMXFILES) $(OCAMLDOC_LIBCMA): $(LIBCMOFILES) - $(OCAMLC) -a -o $@ $(LINKFLAGS) $(OCAMLCMOFILES) $(LIBCMOFILES) + $(OCAMLC) -a -o $@ $(LINKFLAGS) $(OCAMLSRCDIR)/tools/depend.cmo \ + $(LIBCMOFILES) $(OCAMLDOC_LIBCMXA): $(LIBCMXFILES) - $(OCAMLOPT) -a -o $@ $(LINKFLAGS) $(OCAMLCMXFILES) $(LIBCMXFILES) + $(OCAMLOPT) -a -o $@ $(LINKFLAGS) $(OCAMLSRCDIR)/tools/depend.cmx \ + $(LIBCMXFILES) # Parsers and lexers dependencies : ################################### @@ -222,7 +231,7 @@ installopt_really: ############################ clean:: dummy - @rm -f *~ /#*/# + @rm -f *~ \#*\# @rm -f $(OCAMLDOC) $(OCAMLDOC_OPT) *.cma *.cmxa *.cmo *.cmi *.cmx *.$(A) *.$(O) @rm -f odoc_parser.output odoc_text_parser.output @rm -f odoc_lexer.ml odoc_text_lexer.ml odoc_see_lexer.ml odoc_ocamlhtml.ml diff --git a/ocamldoc/odoc_analyse.ml b/ocamldoc/odoc_analyse.ml index 31328838f4..fd69b0a74d 100644 --- a/ocamldoc/odoc_analyse.ml +++ b/ocamldoc/odoc_analyse.ml @@ -440,7 +440,7 @@ let analyse_files ?(init=[]) files = ); if !Odoc_global.sort_modules then - Sort.list (fun m1 -> fun m2 -> m1.Odoc_module.m_name < m2.Odoc_module.m_name) merged_modules + List.sort (fun m1 m2 -> compare m1.Odoc_module.m_name m2.Odoc_module.m_name) merged_modules else merged_modules diff --git a/ocamldoc/odoc_dag2html.ml b/ocamldoc/odoc_dag2html.ml index 44a0aa9c13..74119e6e8b 100644 --- a/ocamldoc/odoc_dag2html.ml +++ b/ocamldoc/odoc_dag2html.ml @@ -387,10 +387,10 @@ let group_by_common_children d list = let copy_data d = {elem = d.elem; span = d.span};; let insert_columns t nb j = - let t1 = Array.create (Array.length t.table) [| |] in + let t1 = Array.make (Array.length t.table) [| |] in for i = 0 to Array.length t.table - 1 do let line = t.table.(i) in - let line1 = Array.create (Array.length line + nb) line.(0) in + let line1 = Array.make (Array.length line + nb) line.(0) in t1.(i) <- line1; let rec loop k = if k = Array.length line then () diff --git a/ocamldoc/odoc_html.ml b/ocamldoc/odoc_html.ml index 96f2dfc7e5..9ed06c0f09 100644 --- a/ocamldoc/odoc_html.ml +++ b/ocamldoc/odoc_html.ml @@ -1203,7 +1203,7 @@ class html = s_final in let s2 = Str.global_substitute - (Str.regexp "\\([A-Z]\\([a-zA-Z_'0-9]\\)*\\.\\)+\\([A-Z][a-zA-Z_'0-9]*\\)") + (Str.regexp "\\([A-Z]\\([a-zA-Z_'0-9]\\)*\\)\\(\\.[A-Z][a-zA-Z_'0-9]*\\)*") f s in diff --git a/ocamldoc/odoc_man.ml b/ocamldoc/odoc_man.ml index def2377882..e97db4bc5b 100644 --- a/ocamldoc/odoc_man.ml +++ b/ocamldoc/odoc_man.ml @@ -1290,7 +1290,7 @@ class man = (** Generate all the man pages from a module list. *) method generate module_list = - let sorted_module_list = Sort.list (fun m1 -> fun m2 -> m1.m_name < m2.m_name) module_list in + let sorted_module_list = List.sort (fun m1 m2 -> compare m1.m_name m2.m_name) module_list in let groups = self#create_groups !man_mini sorted_module_list in let f group = match group with diff --git a/ocamldoc/odoc_print.ml b/ocamldoc/odoc_print.ml index 3fa826af97..56a85e5fda 100644 --- a/ocamldoc/odoc_print.ml +++ b/ocamldoc/odoc_print.ml @@ -25,13 +25,9 @@ let new_fmt () = let (type_fmt, flush_type_fmt) = new_fmt () let _ = - let (out, flush, outnewline, outspace) = - pp_get_all_formatter_output_functions type_fmt () - in - pp_set_all_formatter_output_functions type_fmt - ~out ~flush - ~newline: (fun () -> out "\n " 0 3) - ~spaces: outspace + let outfuns = pp_get_formatter_out_functions type_fmt () in + pp_set_formatter_out_functions type_fmt + {outfuns with out_newline = fun () -> outfuns.out_string "\n " 0 3} let (modtype_fmt, flush_modtype_fmt) = new_fmt () diff --git a/ocamldoc/odoc_sig.ml b/ocamldoc/odoc_sig.ml index 48fe8cd7f4..e41cf2b8db 100644 --- a/ocamldoc/odoc_sig.ml +++ b/ocamldoc/odoc_sig.ml @@ -1290,11 +1290,19 @@ module Analyser = and analyse_module_kind ?(erased = Name.Set.empty) env current_module_name module_type sig_module_type = match module_type.Parsetree.pmty_desc with - Parsetree.Pmty_ident longident - | Parsetree.Pmty_alias longident -> + | Parsetree.Pmty_ident longident -> let k = analyse_module_type_kind env current_module_name module_type sig_module_type in Module_with ( k, "" ) - + | Parsetree.Pmty_alias longident -> + begin + match sig_module_type with + Types.Mty_alias path -> + let alias_name = Odoc_env.full_module_name env (Name.from_path path) in + let ma = { ma_name = alias_name ; ma_module = None } in + Module_alias ma + | _ -> + raise (Failure "Parsetree.Pmty_alias _ but not Types.Mty_alias _") + end | Parsetree.Pmty_signature signature -> ( let signature = filter_out_erased_items_from_signature erased signature in diff --git a/otherlibs/bigarray/.depend b/otherlibs/bigarray/.depend index d705f2022e..889328a333 100644 --- a/otherlibs/bigarray/.depend +++ b/otherlibs/bigarray/.depend @@ -5,7 +5,7 @@ bigarray_stubs.o: bigarray_stubs.c ../../byterun/alloc.h \ ../../byterun/fail.h ../../byterun/intext.h ../../byterun/io.h \ ../../byterun/hash.h ../../byterun/memory.h ../../byterun/gc.h \ ../../byterun/major_gc.h ../../byterun/freelist.h \ - ../../byterun/minor_gc.h ../../byterun/int64_native.h + ../../byterun/minor_gc.h mmap_unix.o: mmap_unix.c bigarray.h ../../byterun/config.h \ ../../byterun/../config/m.h ../../byterun/../config/s.h \ ../../byterun/mlvalues.h ../../byterun/config.h ../../byterun/misc.h \ diff --git a/otherlibs/bigarray/bigarray_stubs.c b/otherlibs/bigarray/bigarray_stubs.c index 586357ad57..f2ccb92ba1 100644 --- a/otherlibs/bigarray/bigarray_stubs.c +++ b/otherlibs/bigarray/bigarray_stubs.c @@ -279,9 +279,9 @@ value caml_ba_get_N(value vb, value * vind, int nind) case CAML_BA_UINT16: return Val_int(((uint16 *) b->data)[offset]); case CAML_BA_INT32: - return caml_copy_int32(((int32 *) b->data)[offset]); + return caml_copy_int32(((int32_t *) b->data)[offset]); case CAML_BA_INT64: - return caml_copy_int64(((int64 *) b->data)[offset]); + return caml_copy_int64(((int64_t *) b->data)[offset]); case CAML_BA_NATIVE_INT: return caml_copy_nativeint(((intnat *) b->data)[offset]); case CAML_BA_CAML_INT: @@ -293,7 +293,7 @@ value caml_ba_get_N(value vb, value * vind, int nind) { double * p = ((double *) b->data) + offset * 2; return copy_two_doubles(p[0], p[1]); } case CAML_BA_CHAR: - return Val_int(((char *) b->data)[offset]); + return Val_int(((unsigned char *) b->data)[offset]); } } @@ -388,7 +388,7 @@ CAMLprim value caml_ba_uint8_get32(value vb, value vind) CAMLprim value caml_ba_uint8_get64(value vb, value vind) { - uint64 res; + uint64_t res; unsigned char b1, b2, b3, b4, b5, b6, b7, b8; intnat idx = Long_val(vind); struct caml_ba_array * b = Caml_ba_array_val(vb); @@ -402,15 +402,15 @@ CAMLprim value caml_ba_uint8_get64(value vb, value vind) b7 = ((unsigned char*) b->data)[idx+6]; b8 = ((unsigned char*) b->data)[idx+7]; #ifdef ARCH_BIG_ENDIAN - res = (uint64) b1 << 56 | (uint64) b2 << 48 - | (uint64) b3 << 40 | (uint64) b4 << 32 - | (uint64) b5 << 24 | (uint64) b6 << 16 - | (uint64) b7 << 8 | (uint64) b8; + res = (uint64_t) b1 << 56 | (uint64_t) b2 << 48 + | (uint64_t) b3 << 40 | (uint64_t) b4 << 32 + | (uint64_t) b5 << 24 | (uint64_t) b6 << 16 + | (uint64_t) b7 << 8 | (uint64_t) b8; #else - res = (uint64) b8 << 56 | (uint64) b7 << 48 - | (uint64) b6 << 40 | (uint64) b5 << 32 - | (uint64) b4 << 24 | (uint64) b3 << 16 - | (uint64) b2 << 8 | (uint64) b1; + res = (uint64_t) b8 << 56 | (uint64_t) b7 << 48 + | (uint64_t) b6 << 40 | (uint64_t) b5 << 32 + | (uint64_t) b4 << 24 | (uint64_t) b3 << 16 + | (uint64_t) b2 << 8 | (uint64_t) b1; #endif return caml_copy_int64(res); } @@ -447,9 +447,9 @@ static value caml_ba_set_aux(value vb, value * vind, intnat nind, value newval) case CAML_BA_UINT16: ((int16 *) b->data)[offset] = Int_val(newval); break; case CAML_BA_INT32: - ((int32 *) b->data)[offset] = Int32_val(newval); break; + ((int32_t *) b->data)[offset] = Int32_val(newval); break; case CAML_BA_INT64: - ((int64 *) b->data)[offset] = Int64_val(newval); break; + ((int64_t *) b->data)[offset] = Int64_val(newval); break; case CAML_BA_NATIVE_INT: ((intnat *) b->data)[offset] = Nativeint_val(newval); break; case CAML_BA_CAML_INT: @@ -577,7 +577,7 @@ CAMLprim value caml_ba_uint8_set64(value vb, value vind, value newval) { unsigned char b1, b2, b3, b4, b5, b6, b7, b8; intnat idx = Long_val(vind); - int64 val; + int64_t val; struct caml_ba_array * b = Caml_ba_array_val(vb); if (idx < 0 || idx >= b->dim[0] - 7) caml_array_bound_error(); val = Int64_val(newval); @@ -750,7 +750,7 @@ static int caml_ba_compare(value v1, value v2) case CAML_BA_FLOAT64: DO_FLOAT_COMPARISON(double); case CAML_BA_CHAR: - DO_INTEGER_COMPARISON(char); + DO_INTEGER_COMPARISON(uint8); case CAML_BA_SINT8: DO_INTEGER_COMPARISON(int8); case CAML_BA_UINT8: @@ -760,9 +760,9 @@ static int caml_ba_compare(value v1, value v2) case CAML_BA_UINT16: DO_INTEGER_COMPARISON(uint16); case CAML_BA_INT32: - DO_INTEGER_COMPARISON(int32); + DO_INTEGER_COMPARISON(int32_t); case CAML_BA_INT64: - DO_INTEGER_COMPARISON(int64); + DO_INTEGER_COMPARISON(int64_t); case CAML_BA_CAML_INT: case CAML_BA_NATIVE_INT: DO_INTEGER_COMPARISON(intnat); @@ -780,7 +780,7 @@ static intnat caml_ba_hash(value v) { struct caml_ba_array * b = Caml_ba_array_val(v); intnat num_elts, n; - uint32 h, w; + uint32_t h, w; int i; num_elts = 1; @@ -820,7 +820,7 @@ static intnat caml_ba_hash(value v) } case CAML_BA_INT32: { - uint32 * p = b->data; + uint32_t * p = b->data; if (num_elts > 64) num_elts = 64; for (n = 0; n < num_elts; n++, p++) h = caml_hash_mix_uint32(h, *p); break; @@ -835,7 +835,7 @@ static intnat caml_ba_hash(value v) } case CAML_BA_INT64: { - int64 * p = b->data; + int64_t * p = b->data; if (num_elts > 32) num_elts = 32; for (n = 0; n < num_elts; n++, p++) h = caml_hash_mix_int64(h, *p); break; @@ -878,7 +878,7 @@ static void caml_ba_serialize_longarray(void * data, } else { caml_serialize_int_1(0); for (n = 0, p = data; n < num_elts; n++, p++) - caml_serialize_int_4((int32) *p); + caml_serialize_int_4((int32_t) *p); } #else caml_serialize_int_1(0); @@ -1169,7 +1169,7 @@ CAMLprim value caml_ba_fill(value vb, value vinit) case CAML_BA_SINT8: case CAML_BA_UINT8: { int init = Int_val(vinit); - char * p; + unsigned char * p; for (p = b->data; num_elts > 0; p++, num_elts--) *p = init; break; } @@ -1181,14 +1181,14 @@ CAMLprim value caml_ba_fill(value vb, value vinit) break; } case CAML_BA_INT32: { - int32 init = Int32_val(vinit); - int32 * p; + int32_t init = Int32_val(vinit); + int32_t * p; for (p = b->data; num_elts > 0; p++, num_elts--) *p = init; break; } case CAML_BA_INT64: { - int64 init = Int64_val(vinit); - int64 * p; + int64_t init = Int64_val(vinit); + int64_t * p; for (p = b->data; num_elts > 0; p++, num_elts--) *p = init; break; } diff --git a/otherlibs/dynlink/dynlink.mli b/otherlibs/dynlink/dynlink.mli index 4ced87606e..98ded877cb 100644 --- a/otherlibs/dynlink/dynlink.mli +++ b/otherlibs/dynlink/dynlink.mli @@ -43,17 +43,22 @@ val adapt_filename : string -> string (** {6 Access control} *) val allow_only: string list -> unit -(** [allow_only units] restricts the compilation units that dynamically-linked - units can reference: it only allows references to the units named in - list [units]. References to any other compilation unit will cause - a [Unavailable_unit] error during [loadfile] or [loadfile_private]. - - Initially (just after calling [init]), all compilation units composing - the program currently running are available for reference from - dynamically-linked units. [allow_only] can be used to grant access - to some of them only, e.g. to the units that compose the API for +(** [allow_only units] restricts the compilation units that + dynamically-linked units can reference: it forbids all references + to units other than those named in the list [units]. References + to any other compilation unit will cause a [Unavailable_unit] + error during [loadfile] or [loadfile_private]. + + Initially (or after calling [default_available_units]) all + compilation units composing the program currently running are + available for reference from dynamically-linked units. + [allow_only] can be used to restrict access to a subset of these + units, e.g. to the units that compose the API for dynamically-linked code, and prevent access to all other units, - e.g. private, internal modules of the running program. *) + e.g. private, internal modules of the running program. If + [allow_only] is called several times, access will be restricted to + the intersection of the given lists (i.e. a call to [allow_only] + can never increase the set of available units). *) val prohibit: string list -> unit (** [prohibit units] prohibits dynamically-linked units from referencing diff --git a/otherlibs/num/nat_stubs.c b/otherlibs/num/nat_stubs.c index 9a62759fac..d718a05383 100644 --- a/otherlibs/num/nat_stubs.c +++ b/otherlibs/num/nat_stubs.c @@ -347,9 +347,9 @@ static void serialize_nat(value nat, if (len >= ((mlsize_t)1 << 32)) failwith("output_value: nat too big"); #endif - serialize_int_4((int32) len); + serialize_int_4((int32_t) len); #if defined(ARCH_SIXTYFOUR) && defined(ARCH_BIG_ENDIAN) - { int32 * p; + { int32_t * p; mlsize_t i; for (i = len, p = Data_custom_val(nat); i > 0; i -= 2, p += 2) { serialize_int_4(p[1]); /* low 32 bits of 64-bit digit */ @@ -369,7 +369,7 @@ static uintnat deserialize_nat(void * dst) len = deserialize_uint_4(); #if defined(ARCH_SIXTYFOUR) && defined(ARCH_BIG_ENDIAN) - { uint32 * p; + { uint32_t * p; mlsize_t i; for (i = len, p = dst; i > 1; i -= 2, p += 2) { p[1] = deserialize_uint_4(); /* low 32 bits of 64-bit digit */ @@ -385,7 +385,7 @@ static uintnat deserialize_nat(void * dst) deserialize_block_4(dst, len); #if defined(ARCH_SIXTYFOUR) if (len & 1){ - ((uint32 *) dst)[len] = 0; + ((uint32_t *) dst)[len] = 0; ++ len; } #endif @@ -396,7 +396,7 @@ static uintnat deserialize_nat(void * dst) static intnat hash_nat(value v) { bngsize len, i; - uint32 h; + uint32_t h; len = bng_num_digits(&Digit_val(v,0), Wosize_val(v) - 1); h = 0; @@ -406,10 +406,10 @@ static intnat hash_nat(value v) /* Mix the two 32-bit halves as if we were on a 32-bit platform, namely low 32 bits first, then high 32 bits. Also, ignore final 32 bits if they are zero. */ - h = caml_hash_mix_uint32(h, (uint32) d); + h = caml_hash_mix_uint32(h, (uint32_t) d); d = d >> 32; if (d == 0 && i + 1 == len) break; - h = caml_hash_mix_uint32(h, (uint32) d); + h = caml_hash_mix_uint32(h, (uint32_t) d); #else h = caml_hash_mix_uint32(h, d); #endif diff --git a/otherlibs/systhreads/event.ml b/otherlibs/systhreads/event.ml index 1feac525fc..68d8a5b456 100644 --- a/otherlibs/systhreads/event.ml +++ b/otherlibs/systhreads/event.ml @@ -69,7 +69,7 @@ let do_aborts abort_env genev performed = let basic_sync abort_env genev = let performed = ref (-1) in let condition = Condition.create() in - let bev = Array.create (Array.length genev) + let bev = Array.make (Array.length genev) (fst (genev.(0)) performed condition 0) in for i = 1 to Array.length genev - 1 do bev.(i) <- (fst genev.(i)) performed condition i @@ -143,7 +143,7 @@ let sync ev = let basic_poll abort_env genev = let performed = ref (-1) in let condition = Condition.create() in - let bev = Array.create(Array.length genev) + let bev = Array.make(Array.length genev) (fst genev.(0) performed condition 0) in for i = 1 to Array.length genev - 1 do bev.(i) <- fst genev.(i) performed condition i diff --git a/otherlibs/threads/.depend b/otherlibs/threads/.depend index bc03050be3..3a6c7f02b6 100644 --- a/otherlibs/threads/.depend +++ b/otherlibs/threads/.depend @@ -11,25 +11,22 @@ scheduler.o: scheduler.c ../../byterun/alloc.h \ ../../byterun/sys.h condition.cmi : mutex.cmi event.cmi : -marshal.cmi : mutex.cmi : -pervasives.cmi : -thread.cmi : unix.cmi -threadUnix.cmi : unix.cmi -unix.cmi : +thread.cmi : unix.cmo +threadUnix.cmi : unix.cmo condition.cmo : thread.cmi mutex.cmi condition.cmi condition.cmx : thread.cmx mutex.cmx condition.cmi event.cmo : mutex.cmi condition.cmi event.cmi event.cmx : mutex.cmx condition.cmx event.cmi -marshal.cmo : pervasives.cmi marshal.cmi -marshal.cmx : pervasives.cmx marshal.cmi +marshal.cmo : +marshal.cmx : mutex.cmo : thread.cmi mutex.cmi mutex.cmx : thread.cmx mutex.cmi -pervasives.cmo : unix.cmi pervasives.cmi -pervasives.cmx : unix.cmx pervasives.cmi -thread.cmo : unix.cmi thread.cmi +pervasives.cmo : unix.cmo +pervasives.cmx : unix.cmx +thread.cmo : unix.cmo thread.cmi thread.cmx : unix.cmx thread.cmi -threadUnix.cmo : unix.cmi thread.cmi threadUnix.cmi +threadUnix.cmo : unix.cmo thread.cmi threadUnix.cmi threadUnix.cmx : unix.cmx thread.cmx threadUnix.cmi -unix.cmo : unix.cmi -unix.cmx : unix.cmi +unix.cmo : +unix.cmx : diff --git a/otherlibs/threads/event.ml b/otherlibs/threads/event.ml index 1feac525fc..68d8a5b456 100644 --- a/otherlibs/threads/event.ml +++ b/otherlibs/threads/event.ml @@ -69,7 +69,7 @@ let do_aborts abort_env genev performed = let basic_sync abort_env genev = let performed = ref (-1) in let condition = Condition.create() in - let bev = Array.create (Array.length genev) + let bev = Array.make (Array.length genev) (fst (genev.(0)) performed condition 0) in for i = 1 to Array.length genev - 1 do bev.(i) <- (fst genev.(i)) performed condition i @@ -143,7 +143,7 @@ let sync ev = let basic_poll abort_env genev = let performed = ref (-1) in let condition = Condition.create() in - let bev = Array.create(Array.length genev) + let bev = Array.make(Array.length genev) (fst genev.(0) performed condition 0) in for i = 1 to Array.length genev - 1 do bev.(i) <- fst genev.(i) performed condition i diff --git a/otherlibs/unix/.depend b/otherlibs/unix/.depend index 63e1d22935..85eee1b853 100644 --- a/otherlibs/unix/.depend +++ b/otherlibs/unix/.depend @@ -137,8 +137,8 @@ getaddrinfo.o: getaddrinfo.c ../../byterun/mlvalues.h \ ../../byterun/misc.h ../../byterun/alloc.h ../../byterun/mlvalues.h \ ../../byterun/fail.h ../../byterun/memory.h ../../byterun/gc.h \ ../../byterun/major_gc.h ../../byterun/freelist.h \ - ../../byterun/minor_gc.h ../../byterun/signals.h unixsupport.h \ - cst2constr.h socketaddr.h ../../byterun/misc.h + ../../byterun/minor_gc.h ../../byterun/misc.h ../../byterun/signals.h \ + unixsupport.h cst2constr.h socketaddr.h getcwd.o: getcwd.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ ../../byterun/config.h ../../byterun/../config/m.h \ ../../byterun/../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \ @@ -301,7 +301,8 @@ open.o: open.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ ../../byterun/../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \ ../../byterun/mlvalues.h ../../byterun/memory.h ../../byterun/gc.h \ ../../byterun/major_gc.h ../../byterun/freelist.h \ - ../../byterun/minor_gc.h ../../byterun/signals.h unixsupport.h + ../../byterun/minor_gc.h ../../byterun/misc.h ../../byterun/signals.h \ + unixsupport.h opendir.o: opendir.c ../../byterun/mlvalues.h \ ../../byterun/compatibility.h ../../byterun/config.h \ ../../byterun/../config/m.h ../../byterun/../config/s.h \ diff --git a/otherlibs/unix/addrofstr.c b/otherlibs/unix/addrofstr.c index e17841f954..a2830ba593 100644 --- a/otherlibs/unix/addrofstr.c +++ b/otherlibs/unix/addrofstr.c @@ -73,7 +73,7 @@ CAMLprim value unix_inet_addr_of_string(value s) #else struct in_addr address; address.s_addr = inet_addr(String_val(s)); - if (address.s_addr == (uint32) -1) failwith("inet_addr_of_string"); + if (address.s_addr == (uint32_t) -1) failwith("inet_addr_of_string"); return alloc_inet_addr(&address); #endif } diff --git a/otherlibs/unix/unix.mli b/otherlibs/unix/unix.mli index 59e5199357..dea5cb30be 100644 --- a/otherlibs/unix/unix.mli +++ b/otherlibs/unix/unix.mli @@ -11,7 +11,11 @@ (* *) (***********************************************************************) -(** Interface to the Unix system *) +(** Interface to the Unix system. + + Note: all the functions of this module (except [error_message] and + [handle_unix_error]) are liable to raise the [Unix_error] + exception whenever the underlying system call signals an error. *) (** {6 Error report} *) @@ -291,12 +295,27 @@ val single_write_substring : file_descr -> string -> int -> int -> int val in_channel_of_descr : file_descr -> in_channel (** Create an input channel reading from the given descriptor. The channel is initially in binary mode; use - [set_binary_mode_in ic false] if text mode is desired. *) + [set_binary_mode_in ic false] if text mode is desired. + Beware that channels are buffered so more characters may have been + read from the file descriptor than those accessed using channel functions. + Channels also keep a copy of the current position in the file. + + You need to explicitly close all channels created with this function. + Closing the channel also closes the underlying file descriptor (unless + it was already closed). *) val out_channel_of_descr : file_descr -> out_channel (** Create an output channel writing on the given descriptor. The channel is initially in binary mode; use - [set_binary_mode_out oc false] if text mode is desired. *) + [set_binary_mode_out oc false] if text mode is desired. + Beware that channels are buffered so you may have to [flush] them + to ensure that all data has been sent to the file descriptor. + Channels also keep a copy of the current position in the file. + + You need to explicitly close all channels created with this function. + Closing the channel flushes the data and closes the underlying file + descriptor (unless it has already been closed, in which case the + buffered data is lost).*) val descr_of_in_channel : in_channel -> file_descr (** Return the descriptor corresponding to an input channel. *) diff --git a/otherlibs/win32graph/draw.c b/otherlibs/win32graph/draw.c index fc6cf10220..11426734b0 100644 --- a/otherlibs/win32graph/draw.c +++ b/otherlibs/win32graph/draw.c @@ -57,12 +57,12 @@ CAMLprim value caml_gr_moveto(value vx, value vy) return Val_unit; } -CAMLprim value caml_gr_current_x(void) +CAMLprim value caml_gr_current_x(value unit) { return Val_int(grwindow.grx); } -CAMLprim value caml_gr_current_y(void) +CAMLprim value caml_gr_current_y(value unit) { return Val_int(grwindow.gry); } @@ -311,7 +311,7 @@ CAMLprim value caml_gr_show_bitmap(value filename,int x,int y) -CAMLprim value caml_gr_get_mousex(void) +CAMLprim value caml_gr_get_mousex(value unit) { POINT pt; GetCursorPos(&pt); @@ -319,7 +319,7 @@ CAMLprim value caml_gr_get_mousex(void) return pt.x; } -CAMLprim value caml_gr_get_mousey(void) +CAMLprim value caml_gr_get_mousey(value unit) { POINT pt; GetCursorPos(&pt); diff --git a/otherlibs/win32graph/open.c b/otherlibs/win32graph/open.c index 4138fccde3..ded2e28ae0 100644 --- a/otherlibs/win32graph/open.c +++ b/otherlibs/win32graph/open.c @@ -37,7 +37,7 @@ MSG msg; static char *szOcamlWindowClass = "OcamlWindowClass"; static BOOL gr_initialized = 0; -CAMLprim value caml_gr_clear_graph(void); +CAMLprim value caml_gr_clear_graph(value unit); HANDLE hInst; HFONT CreationFont(char *name) @@ -268,7 +268,7 @@ CAMLprim value caml_gr_open_graph(value arg) return Val_unit; } -CAMLprim value caml_gr_close_graph(void) +CAMLprim value caml_gr_close_graph(value unit) { if (gr_initialized) { PostMessage(grwindow.hwnd, WM_CLOSE, 0, 0); @@ -277,7 +277,7 @@ CAMLprim value caml_gr_close_graph(void) return Val_unit; } -CAMLprim value caml_gr_clear_graph(void) +CAMLprim value caml_gr_clear_graph(value unit) { gr_check_open(); if(grremember_mode) { @@ -291,13 +291,13 @@ CAMLprim value caml_gr_clear_graph(void) return Val_unit; } -CAMLprim value caml_gr_size_x(void) +CAMLprim value caml_gr_size_x(value unit) { gr_check_open(); return Val_int(grwindow.width); } -CAMLprim value caml_gr_size_y(void) +CAMLprim value caml_gr_size_y(value unit) { gr_check_open(); return Val_int(grwindow.height); @@ -312,7 +312,7 @@ CAMLprim value caml_gr_resize_window (value vx, value vy) return Val_unit; } -CAMLprim value caml_gr_synchronize(void) +CAMLprim value caml_gr_synchronize(value unit) { gr_check_open(); BitBlt(grwindow.gc,0,0,grwindow.width,grwindow.height, @@ -337,7 +337,7 @@ CAMLprim value caml_gr_sigio_signal(value unit) return Val_unit; } -CAMLprim value caml_gr_sigio_handler(void) +CAMLprim value caml_gr_sigio_handler(value unit) { return Val_unit; } diff --git a/otherlibs/win32unix/unix.ml b/otherlibs/win32unix/unix.ml index 8866a2cd50..b74f063e83 100644 --- a/otherlibs/win32unix/unix.ml +++ b/otherlibs/win32unix/unix.ml @@ -808,7 +808,7 @@ external win_create_process : string -> string -> string option -> let make_cmdline args = let maybe_quote f = - if String.contains f ' ' || String.contains f '\"' + if String.contains f ' ' || String.contains f '\"' || f = "" then Filename.quote f else f in String.concat " " (List.map maybe_quote (Array.to_list args)) diff --git a/parsing/lexer.mli b/parsing/lexer.mli index 79e3b8e958..9898e97198 100644 --- a/parsing/lexer.mli +++ b/parsing/lexer.mli @@ -47,6 +47,12 @@ to call to initialize the preprocessor when the lexer is initialized, and [preprocessor] a function that is called when a new token is needed by the parser, as [preprocessor lexer lexbuf] where [lexer] is the lexing function. + +When a preprocessor is configured by calling [set_preprocessor], the lexer +changes its behavior: +- It accepts backslash-newline as a token-separating blank. +- It emits an EOL token for every newline except those preceeded by backslash + and those in strings or comments. *) val set_preprocessor : diff --git a/parsing/parser.mly b/parsing/parser.mly index fa0d3c636a..c6b3c4de6e 100644 --- a/parsing/parser.mly +++ b/parsing/parser.mly @@ -704,8 +704,8 @@ module_type: { mkmty(Pmty_with($1, List.rev $3)) } | MODULE TYPE OF module_expr %prec below_LBRACKETAT { mkmty(Pmty_typeof $4) } - | LPAREN MODULE mod_longident RPAREN - { mkmty (Pmty_alias (mkrhs $3 3)) } +/* | LPAREN MODULE mod_longident RPAREN + { mkmty (Pmty_alias (mkrhs $3 3)) } */ | LPAREN module_type RPAREN { $2 } | LPAREN module_type error @@ -827,7 +827,7 @@ class_expr: { $2 } | class_simple_expr simple_labeled_expr_list { mkclass(Pcl_apply($1, List.rev $2)) } - | LET rec_flag let_bindings IN class_expr + | LET rec_flag let_bindings_no_attrs IN class_expr { mkclass(Pcl_let ($2, List.rev $3, $5)) } | class_expr attribute { Cl.attr $1 $2 } @@ -942,11 +942,7 @@ class_type: { mkcty(Pcty_arrow($1, $3, $5)) } | simple_core_type_or_tuple_no_attr MINUSGREATER class_type { mkcty(Pcty_arrow("", $1, $3)) } - | class_type attribute - { Cty.attr $1 $2 } - | extension - { mkcty(Pcty_extension $1) } -; + ; class_signature: LBRACKET core_type_comma_list RBRACKET clty_longident { mkcty(Pcty_constr (mkloc $4 (rhs_loc 4), List.rev $2)) } @@ -956,6 +952,10 @@ class_signature: { mkcty(Pcty_signature $2) } | OBJECT class_sig_body error { unclosed "object" 1 "end" 3 } + | class_signature attribute + { Cty.attr $1 $2 } + | extension + { mkcty(Pcty_extension $1) } ; class_sig_body: class_self_type class_sig_fields @@ -1082,7 +1082,7 @@ expr: { $1 } | simple_expr simple_labeled_expr_list { mkexp(Pexp_apply($1, List.rev $2)) } - | LET ext_attributes rec_flag let_bindings IN seq_expr + | LET ext_attributes rec_flag let_bindings_no_attrs IN seq_expr { mkexp_attrs (Pexp_let($3, List.rev $4, $6)) $2 } | LET MODULE ext_attributes UIDENT module_binding_body IN seq_expr { mkexp_attrs (Pexp_letmodule(mkrhs $4 4, $5, $7)) $3 } @@ -1321,6 +1321,17 @@ let_bindings: let_binding { [$1] } | let_bindings AND let_binding { $3 :: $1 } ; +let_bindings_no_attrs: + let_bindings { + let l = $1 in + List.iter + (fun vb -> + if vb.pvb_attributes <> [] then + raise Syntaxerr.(Error(Not_expecting(vb.pvb_loc,"item attribute"))) + ) + l; + l + } lident_list: LIDENT { [$1] } diff --git a/parsing/parsetree.mli b/parsing/parsetree.mli index 75b8528c65..d287b9eee7 100644 --- a/parsing/parsetree.mli +++ b/parsing/parsetree.mli @@ -60,7 +60,10 @@ and core_type_desc = ?l:T1 -> T2 (label = "?l") *) | Ptyp_tuple of core_type list - (* T1 * ... * Tn (n >= 2) *) + (* T1 * ... * Tn + + Invariant: n >= 2 + *) | Ptyp_constr of Longident.t loc * core_type list (* tconstr T tconstr @@ -155,7 +158,10 @@ and pattern_desc = Other forms of interval are recognized by the parser but rejected by the type-checker. *) | Ppat_tuple of pattern list - (* (P1, ..., Pn) (n >= 2) *) + (* (P1, ..., Pn) + + Invariant: n >= 2 + *) | Ppat_construct of Longident.t loc * pattern option (* C None C P Some P @@ -168,6 +174,8 @@ and pattern_desc = | Ppat_record of (Longident.t loc * pattern) list * closed_flag (* { l1=P1; ...; ln=Pn } (flag = Closed) { l1=P1; ...; ln=Pn; _} (flag = Open) + + Invariant: n > 0 *) | Ppat_array of pattern list (* [| P1; ...; Pn |] *) @@ -226,13 +234,18 @@ and expression_desc = (* E0 ~l1:E1 ... ~ln:En li can be empty (non labeled argument) or start with '?' (optional argument). + + Invariant: n > 0 *) | Pexp_match of expression * case list (* match E0 with P1 -> E1 | ... | Pn -> En *) | Pexp_try of expression * case list (* try E0 with P1 -> E1 | ... | Pn -> En *) | Pexp_tuple of expression list - (* (E1, ..., En) (n >= 2) *) + (* (E1, ..., En) + + Invariant: n >= 2 + *) | Pexp_construct of Longident.t loc * expression option (* C None C E Some E @@ -245,6 +258,8 @@ and expression_desc = | Pexp_record of (Longident.t loc * expression) list * expression option (* { l1=P1; ...; ln=Pn } (None) { E0 with l1=P1; ...; ln=Pn } (Some E0) + + Invariant: n > 0 *) | Pexp_field of expression * Longident.t loc (* E.l *) @@ -360,7 +375,9 @@ and type_declaration = and type_kind = | Ptype_abstract | Ptype_variant of constructor_declaration list + (* Invariant: non-empty list *) | Ptype_record of label_declaration list + (* Invariant: non-empty list *) | Ptype_open and label_declaration = @@ -375,7 +392,7 @@ and label_declaration = (* { ...; l: T; ... } (mutable=Immutable) { ...; mutable l: T; ... } (mutable=Mutable) - Note: T can be a Pexp_poly. + Note: T can be a Ptyp_poly. *) and constructor_declaration = @@ -481,7 +498,7 @@ and class_type_field_desc = | Pctf_method of (string * private_flag * virtual_flag * core_type) (* method x: T - Note: T can be a Pexp_poly. + Note: T can be a Ptyp_poly. *) | Pctf_constraint of (core_type * core_type) (* constraint T1 = T2 *) @@ -535,6 +552,8 @@ and class_expr_desc = (* CE ~l1:E1 ... ~ln:En li can be empty (non labeled argument) or start with '?' (optional argument). + + Invariant: n > 0 *) | Pcl_let of rec_flag * value_binding list * class_expr (* let P1 = E1 and ... and Pn = EN in CE (flag = Nonrecursive) diff --git a/parsing/pprintast.ml b/parsing/pprintast.ml index 31e5edf0c4..7a1ff4a8c3 100644 --- a/parsing/pprintast.ml +++ b/parsing/pprintast.ml @@ -268,7 +268,8 @@ class printer ()= object(self:'self) | Ptyp_variant (l, closed, low) -> let type_variant_helper f x = match x with - | Rtag (l, _attrs, _, ctl) -> pp f "@[<2>%a%a@]" self#string_quot l + | Rtag (l, attrs, _, ctl) -> pp f "@[<2>%a%a%a@]" self#string_quot l + self#attributes attrs (fun f l -> match l with |[] -> () | _ -> pp f "@;of@;%a" @@ -294,8 +295,9 @@ class printer ()= object(self:'self) pp f ">@ %a" (self#list self#string_quot) xs) low | Ptyp_object (l, o) -> - let core_field_type f (s, _attrs, ct) = - pp f "@[<hov2>%s@ :%a@ @]" s self#core_type ct + let core_field_type f (s, attrs, ct) = + pp f "@[<hov2>%s%a@ :%a@ @]" s + self#attributes attrs self#core_type ct in let field_var f = function | Asttypes.Closed -> () @@ -318,8 +320,7 @@ class printer ()= object(self:'self) |_ -> pp f "@[<hov2>(module@ %a@ with@ %a)@]" self#longident_loc lid (self#list aux ~sep:"@ and@ ") cstrs) - | Ptyp_extension (s, arg) -> - pp f "@[<2>(&%s@ %a)@]" s.txt self#payload arg + | Ptyp_extension e -> self#extension f e | _ -> self#paren true self#core_type f x (********************pattern********************) (* be cautious when use [pattern], [pattern1] is preferred *) @@ -457,53 +458,58 @@ class printer ()= object(self:'self) {txt= Ldot (Ldot (Lident "Bigarray", array), ("get"|"set" as gs)) ;_};_}, label_exprs) -> - begin match array,gs with - | "Genarray","get" -> - begin match label_exprs with - | [(_,a);(_,{pexp_desc=Pexp_array ls;_})] -> begin - pp f "@[%a.{%a}@]" self#simple_expr a - (self#list ~sep:"," self#simple_expr ) ls; - true - end - | _ -> false - end - | "Genarray","set" -> - begin match label_exprs with - | [(_,a);(_,{pexp_desc=Pexp_array ls;_});(_,c)] -> begin - pp f "@[%a.{%a}@ <-@ %a@]" self#simple_expr a - (self#list ~sep:"," self#simple_expr ) ls self#simple_expr c; - true - end - | _ -> false - end - | ("Array1"|"Array2"|"Array3"),"set" -> - begin - match label_exprs with - | (_,a)::rest -> - begin match List.rev rest with - | (_,v)::rest -> - let args = List.map snd (List.rev rest) in - pp f "@[%a.{%a}@ <-@ %a@]" - self#simple_expr a (self#list ~sep:"," - self#simple_expr) - args self#simple_expr v; - true - | _ -> assert false - end - | _ -> assert false - end - | ("Array1"|"Array2"|"Array3"),"get" -> - begin match label_exprs with - |(_,a)::rest -> - pp f "@[%a.{%a}@]" - self#simple_expr a (self#list ~sep:"," self#simple_expr) - (List.map snd rest); - true - | _ -> assert false - end + begin match array, gs, label_exprs with + | "Genarray", "get", + [(_,a);(_,{pexp_desc=Pexp_array ls;_})] -> + pp f "@[%a.{%a}@]" self#simple_expr a + (self#list ~sep:"," self#simple_expr ) ls; + true + | "Genarray", "set", + [(_,a);(_,{pexp_desc=Pexp_array ls;_});(_,c)] -> + pp f "@[%a.{%a}@ <-@ %a@]" self#simple_expr a + (self#list ~sep:"," self#simple_expr ) ls self#simple_expr c; + true + | "Array1", "set", [(_,a);(_,i);(_,v)] -> + pp f "@[%a.{%a}@ <-@ %a@]" + self#simple_expr a + self#simple_expr i + self#simple_expr v; + true + | "Array2", "set", [(_,a);(_,i1);(_,i2);(_,v)] -> + pp f "@[%a.{%a,%a}@ <-@ %a@]" + self#simple_expr a + self#simple_expr i1 + self#simple_expr i2 + self#simple_expr v; + true + | "Array3", "set", [(_,a);(_,i1);(_,i2);(_,i3);(_,v)] -> + pp f "@[%a.{%a,%a,%a}@ <-@ %a@]" + self#simple_expr a + self#simple_expr i1 + self#simple_expr i2 + self#simple_expr i3 + self#simple_expr v; + true + | "Array1", "get", [(_,a);(_,i)] -> + pp f "@[%a.{%a}@]" + self#simple_expr a + self#simple_expr i; + true + | "Array2", "get", [(_,a);(_,i1);(_,i2)] -> + pp f "@[%a.{%a,%a}@]" + self#simple_expr a + self#simple_expr i1 + self#simple_expr i2; + true + | "Array3", "get", [(_,a);(_,i1);(_,i2);(_,i3)] -> + pp f "@[%a.{%a,%a,%a}@]" + self#simple_expr a + self#simple_expr i1 + self#simple_expr i2 + self#simple_expr i3; + true | _ -> false end - | _ -> false method expression f x = if x.pexp_attributes <> [] then begin @@ -602,15 +608,17 @@ class printer ()= object(self:'self) pp f "@[<hov2>assert@ %a@]" self#simple_expr e | Pexp_lazy (e) -> pp f "@[<hov2>lazy@ %a@]" self#simple_expr e - | Pexp_poly _ -> - assert false + (* Pexp_poly: impossible but we should print it anyway, rather than assert false *) + | Pexp_poly (e, None) -> + pp f "@[<hov2>!poly!@ %a@]" self#simple_expr e + | Pexp_poly (e, Some ct) -> + pp f "@[<hov2>(!poly!@ %a@ : %a)@]" self#simple_expr e self#core_type ct | Pexp_open (ovf, lid, e) -> pp f "@[<2>let open%s %a in@;%a@]" (override ovf) self#longident_loc lid self#expression e | Pexp_variant (l,Some eo) -> pp f "@[<2>`%s@;%a@]" l self#simple_expr eo - | Pexp_extension (s, arg) -> - pp f "@[<2>(&%s@ %a)@]" s.txt self#payload arg + | Pexp_extension e -> self#extension f e | _ -> self#expression1 f x method expression1 f x = if x.pexp_attributes <> [] then self#expression f x @@ -679,8 +687,17 @@ class printer ()= object(self:'self) method attributes f l = List.iter (self # attribute f) l + method item_attributes f l = + List.iter (self # item_attribute f) l + method attribute f (s, e) = - pp f "[@@%s %a]" s.txt self#payload e + pp f "@[<2>[@@%s@ %a]@]" s.txt self#payload e + + method item_attribute f (s, e) = + pp f "@[<2>[@@@@%s@ %a]@]" s.txt self#payload e + + method floating_attribute f (s, e) = + pp f "@[<2>[@@@@@@%s@ %a]@]" s.txt self#payload e method value_description f x = pp f "@[<hov2>%a%a@]" self#core_type x.pval_type @@ -691,6 +708,11 @@ class printer ()= object(self:'self) x.pval_prim ; end) x + method extension f (s, e) = + pp f "@[<2>[%%%s@ %a]@]" s.txt self#payload e + + method item_extension f (s, e) = + pp f "@[<2>[%%%%%s@ %a]@]" s.txt self#payload e method exception_declaration f ext = pp f "@[<hov2>exception@ %a@]" self#extension_constructor ext @@ -699,115 +721,154 @@ class printer ()= object(self:'self) let class_type_field f x = match x.pctf_desc with | Pctf_inherit (ct) -> - pp f "@[<2>inherit@ %a@]" self#class_type ct + pp f "@[<2>inherit@ %a@]%a" self#class_type ct + self#item_attributes x.pctf_attributes | Pctf_val (s, mf, vf, ct) -> - pp f "@[<2>val @ %a%a%s@ :@ %a@]" + pp f "@[<2>val @ %a%a%s@ :@ %a@]%a" self#mutable_flag mf self#virtual_flag vf s self#core_type ct + self#item_attributes x.pctf_attributes | Pctf_method (s, pf, vf, ct) -> - pp f "@[<2>method %a %a%s :@;%a@]" + pp f "@[<2>method %a %a%s :@;%a@]%a" self#private_flag pf self#virtual_flag vf s self#core_type ct + self#item_attributes x.pctf_attributes | Pctf_constraint (ct1, ct2) -> - pp f "@[<2>constraint@ %a@ =@ %a@]" + pp f "@[<2>constraint@ %a@ =@ %a@]%a" self#core_type ct1 self#core_type ct2 - | Pctf_attribute _ -> () - | Pctf_extension _ -> assert false + self#item_attributes x.pctf_attributes + | Pctf_attribute a -> self#floating_attribute f a + | Pctf_extension e -> + self#item_extension f e; + self#item_attributes f x.pctf_attributes in - pp f "@[<hv0>@[<hv2>object @[<1>%a@]@ %a@]@ end@]" + pp f "@[<hv0>@[<hv2>object@[<1>%a@]@ %a@]@ end@]" (fun f ct -> match ct.ptyp_desc with | Ptyp_any -> () - | _ -> pp f "(%a)" self#core_type ct) ct + | _ -> pp f " (%a)" self#core_type ct) ct (self#list class_type_field ~sep:"@;") l ; (* call [class_signature] called by [class_signature] *) method class_type f x = match x.pcty_desc with - | Pcty_signature cs -> self#class_signature f cs; + | Pcty_signature cs -> + self#class_signature f cs; + self#attributes f x.pcty_attributes | Pcty_constr (li, l) -> - pp f "%a%a" + pp f "%a%a%a" (fun f l -> match l with | [] -> () | _ -> pp f "[%a]@ " (self#list self#core_type ~sep:"," ) l) l self#longident_loc li + self#attributes x.pcty_attributes | Pcty_arrow (l, co, cl) -> pp f "@[<2>%a@;->@;%a@]" (* FIXME remove parens later *) - self#type_with_label (l,co) self#class_type cl - | Pcty_extension _ -> assert false - + self#type_with_label (l,co) + self#class_type cl + | Pcty_extension e -> + self#extension f e; + self#attributes f x.pcty_attributes (* [class type a = object end] *) method class_type_declaration_list f l = - let class_type_declaration f ({pci_params=ls;pci_name={txt;_};_} as x) = - pp f "%a%a%s@ =@ %a" self#virtual_flag x.pci_virt + let class_type_declaration kwd f ({pci_params=ls;pci_name={txt;_};_} as x) = + pp f "@[<2>%s %a%a%s@ =@ %a@]%a" kwd + self#virtual_flag x.pci_virt self#class_params_def ls txt - self#class_type x.pci_expr in + self#class_type x.pci_expr + self#item_attributes x.pci_attributes + in match l with | [] -> () - | [h] -> pp f "@[<hv2>class type %a@]" class_type_declaration h - | _ -> - pp f "@[<2>class type %a@]" - (self#list class_type_declaration ~sep:"@]@;@[<2>and@;") l + | [x] -> class_type_declaration "class type" f x + | x :: xs -> + pp f "@[<v>%a@,%a@]" + (class_type_declaration "class type") x + (self#list ~sep:"@," (class_type_declaration "and")) xs method class_field f x = match x.pcf_desc with | Pcf_inherit (ovf, ce, so) -> - pp f "@[<2>inherit@ %s@ %a%a@]" (override ovf) self#class_expr ce + pp f "@[<2>inherit@ %s@ %a%a@]%a" (override ovf) + self#class_expr ce (fun f so -> match so with | None -> (); | Some (s) -> pp f "@ as %s" s ) so + self#item_attributes x.pcf_attributes | Pcf_val (s, mf, Cfk_concrete (ovf, e)) -> - pp f "@[<2>val%s %a%s =@;%a@]" (override ovf) self#mutable_flag mf - s.txt self#expression e + pp f "@[<2>val%s %a%s =@;%a@]%a" (override ovf) + self#mutable_flag mf s.txt + self#expression e + self#item_attributes x.pcf_attributes | Pcf_method (s, pf, Cfk_virtual ct) -> - pp f "@[<2>method virtual %a %s :@;%a@]" - self#private_flag pf s.txt self#core_type ct + pp f "@[<2>method virtual %a %s :@;%a@]%a" + self#private_flag pf s.txt + self#core_type ct + self#item_attributes x.pcf_attributes | Pcf_val (s, mf, Cfk_virtual ct) -> - pp f "@[<2>val virtual %a%s :@ %a@]" + pp f "@[<2>val virtual %a%s :@ %a@]%a" self#mutable_flag mf s.txt self#core_type ct + self#item_attributes x.pcf_attributes | Pcf_method (s, pf, Cfk_concrete (ovf, e)) -> - pp f "@[<2>method%s %a%a@]" + let bind e = + self#binding f + {pvb_pat= + {ppat_desc=Ppat_var s;ppat_loc=Location.none;ppat_attributes=[]}; + pvb_expr=e; + pvb_attributes=[]; + pvb_loc=Location.none; + } + in + pp f "@[<2>method%s %a%a@]%a" (override ovf) self#private_flag pf (fun f e -> match e.pexp_desc with | Pexp_poly (e, Some ct) -> pp f "%s :@;%a=@;%a" s.txt (self#core_type) ct self#expression e - | Pexp_poly (e,None) -> - self#binding f {pvb_pat={ppat_desc=Ppat_var s;ppat_loc=Location.none;ppat_attributes=[]}; - pvb_expr=e; - pvb_attributes=[]; - pvb_loc=Location.none; - } - | _ -> - self#expression f e ) e + | Pexp_poly (e,None) -> bind e + | _ -> bind e) e + self#item_attributes x.pcf_attributes | Pcf_constraint (ct1, ct2) -> - pp f "@[<2>constraint %a =@;%a@]" self#core_type ct1 self#core_type ct2 + pp f "@[<2>constraint %a =@;%a@]%a" + self#core_type ct1 + self#core_type ct2 + self#item_attributes x.pcf_attributes | Pcf_initializer (e) -> - pp f "@[<2>initializer@ %a@]" self#expression e - | Pcf_attribute _ -> () - | Pcf_extension _ -> assert false + pp f "@[<2>initializer@ %a@]%a" + self#expression e + self#item_attributes x.pcf_attributes + | Pcf_attribute a -> self#floating_attribute f a + | Pcf_extension e -> + self#item_extension f e; + self#item_attributes f x.pcf_attributes method class_structure f { pcstr_self = p; pcstr_fields = l } = - pp f "@[<hv0>@[<hv2>object %a@;%a@]@;end@]" + pp f "@[<hv0>@[<hv2>object%a@;%a@]@;end@]" (fun f p -> match p.ppat_desc with | Ppat_any -> () - | Ppat_constraint _ -> pp f "%a" self#pattern p - | _ -> pp f "(%a)" self#pattern p) p + | Ppat_constraint _ -> pp f " %a" self#pattern p + | _ -> pp f " (%a)" self#pattern p) p (self#list self#class_field ) l method class_expr f x = + if x.pcl_attributes <> [] then begin + pp f "((%a)%a)" self#class_expr {x with pcl_attributes=[]} + self#attributes x.pcl_attributes + end else match x.pcl_desc with - | Pcl_structure (cs) -> self#class_structure f cs ; + | Pcl_structure (cs) -> self#class_structure f cs | Pcl_fun (l, eo, p, e) -> - pp f "fun@ %a@ ->@ %a" self#label_exp (l,eo,p) self#class_expr e + pp f "fun@ %a@ ->@ %a" + self#label_exp (l,eo,p) + self#class_expr e | Pcl_let (rf, l, ce) -> - (* pp f "let@;%a%a@ in@ %a" *) - pp f "%a@ in@ %a" - (* self#rec_flag rf *) + pp f "%a@ in@ %a" self#bindings (rf,l) self#class_expr ce | Pcl_apply (ce, l) -> - pp f "(%a@ %a)" self#class_expr ce (self#list self#label_x_expression_param) l + pp f "(%a@ %a)" + self#class_expr ce + (self#list self#label_x_expression_param) l | Pcl_constr (li, l) -> pp f "%a%a" (fun f l-> if l <>[] then @@ -818,9 +879,13 @@ class printer ()= object(self:'self) pp f "(%a@ :@ %a)" self#class_expr ce self#class_type ct - | Pcl_extension _ -> assert false + | Pcl_extension e -> self#extension f e method module_type f x = + if x.pmty_attributes <> [] then begin + pp f "((%a)%a)" self#module_type {x with pmty_attributes=[]} + self#attributes x.pmty_attributes + end else match x.pmty_desc with | Pmty_ident li -> pp f "%a" self#longident_loc li; @@ -840,7 +905,7 @@ class printer ()= object(self:'self) let ls = List.map fst ls in pp f "type@ %a %a =@ %a" (self#list self#core_type ~sep:"," ~first:"(" ~last:")") - ls self#longident_loc li self#type_declaration td + ls self#longident_loc li self#type_declaration td | Pwith_module (li, li2) -> pp f "module %a =@ %a" self#longident_loc li self#longident_loc li2; | Pwith_typesubst ({ptype_params=ls;_} as td) -> @@ -858,7 +923,7 @@ class printer ()= object(self:'self) | Pmty_typeof me -> pp f "@[<hov2>module@ type@ of@ %a@]" self#module_expr me - | Pmty_extension _ -> assert false + | Pmty_extension e -> self#extension f e method signature f x = self#list ~sep:"@\n" self#signature_item f x @@ -867,46 +932,51 @@ class printer ()= object(self:'self) | Psig_type l -> self#type_def_list f l | Psig_value vd -> - pp f "@[<2>%a@]" - (fun f vd -> - let intro = if vd.pval_prim = [] then "val" else "external" in - pp f "%s@ %a@ :@ " intro protect_ident vd.pval_name.txt; - self#value_description f vd;) vd + let intro = if vd.pval_prim = [] then "val" else "external" in + pp f "@[<2>%s@ %a@ :@ %a@]%a" intro + protect_ident vd.pval_name.txt + self#value_description vd + self#item_attributes vd.pval_attributes | Psig_typext te -> self#type_extension f te | Psig_exception ed -> self#exception_declaration f ed | Psig_class l -> - let class_description f ({pci_params=ls;pci_name={txt;_};_} as x) = - pp f "%a%a%s@;:@;%a" (* "@[<2>class %a%a%s@;:@;%a@]" *) + let class_description kwd f ({pci_params=ls;pci_name={txt;_};_} as x) = + pp f "@[<2>%s %a%a%s@;:@;%a@]%a" kwd self#virtual_flag x.pci_virt - self#class_params_def - ls - txt self#class_type x.pci_expr in - pp f "@[<0>%a@]" - (fun f l -> match l with - |[] ->() - |[x] -> pp f "@[<2>class %a@]" class_description x - |_ -> - self#list ~first:"@[<v0>class @[<2>" ~sep:"@]@;and @[" - ~last:"@]@]" class_description f l) - l - | Psig_module {pmd_name; pmd_type={pmty_desc=Pmty_alias alias}} -> - pp f "@[<hov>module@ %s@ =@ %a@]" - pmd_name.txt self#longident_loc alias + self#class_params_def ls txt + self#class_type x.pci_expr + self#item_attributes x.pci_attributes + in begin + match l with + | [] -> () + | [x] -> class_description "class" f x + | x :: xs -> + pp f "@[<v>%a@,%a@]" + (class_description "class") x + (self#list ~sep:"@," (class_description "and")) xs + end + | Psig_module ({pmd_type={pmty_desc=Pmty_alias alias};_} as pmd) -> + pp f "@[<hov>module@ %s@ =@ %a@]%a" pmd.pmd_name.txt + self#longident_loc alias + self#item_attributes pmd.pmd_attributes | Psig_module pmd -> - pp f "@[<hov>module@ %s@ :@ %a@]" + pp f "@[<hov>module@ %s@ :@ %a@]%a" pmd.pmd_name.txt - self#module_type pmd.pmd_type + self#module_type pmd.pmd_type + self#item_attributes pmd.pmd_attributes | Psig_open od -> - pp f "@[<hov2>open%s@ %a@]" + pp f "@[<hov2>open%s@ %a@]%a" (override od.popen_override) self#longident_loc od.popen_lid + self#item_attributes od.popen_attributes | Psig_include incl -> - pp f "@[<hov2>include@ %a@]" + pp f "@[<hov2>include@ %a@]%a" self#module_type incl.pincl_mod - | Psig_modtype {pmtd_name=s; pmtd_type=md} -> - pp f "@[<hov2>module@ type@ %s%a@]" + self#item_attributes incl.pincl_attributes + | Psig_modtype {pmtd_name=s; pmtd_type=md; pmtd_attributes=attrs} -> + pp f "@[<hov2>module@ type@ %s%a@]%a" s.txt (fun f md -> match md with | None -> () @@ -914,6 +984,7 @@ class printer ()= object(self:'self) pp_print_space f () ; pp f "@ =@ %a" self#module_type mt ) md + self#item_attributes attrs | Psig_class_type (l) -> self#class_type_declaration_list f l ; | Psig_recmodule decls -> @@ -922,17 +993,26 @@ class printer ()= object(self:'self) | [] -> () ; | pmd :: tl -> if not first then - pp f "@ @[<hov2>and@ %s:@ %a@]" - pmd.pmd_name.txt self#module_type pmd.pmd_type + pp f "@ @[<hov2>and@ %s:@ %a@]%a" pmd.pmd_name.txt + self#module_type pmd.pmd_type + self#item_attributes pmd.pmd_attributes else - pp f "@ @[<hov2>module@ rec@ %s:@ %a@]" - pmd.pmd_name.txt self#module_type pmd.pmd_type; - string_x_module_type_list f ~first:false tl in - string_x_module_type_list f decls - | Psig_attribute _ - | Psig_extension _ -> assert false + pp f "@[<hov2>module@ rec@ %s:@ %a@]%a" pmd.pmd_name.txt + self#module_type pmd.pmd_type + self#item_attributes pmd.pmd_attributes; + string_x_module_type_list f ~first:false tl + in + string_x_module_type_list f decls + | Psig_attribute a -> self#floating_attribute f a + | Psig_extension(e, a) -> + self#item_extension f e; + self#item_attributes f a end method module_expr f x = + if x.pmod_attributes <> [] then begin + pp f "((%a)%a)" self#module_expr {x with pmod_attributes=[]} + self#attributes x.pmod_attributes + end else match x.pmod_desc with | Pmod_structure (s) -> pp f "@[<hv2>struct@;@[<0>%a@]@;<1 -2>end@]" @@ -952,11 +1032,15 @@ class printer ()= object(self:'self) pp f "%a(%a)" self#module_expr me1 self#module_expr me2 | Pmod_unpack e -> pp f "(val@ %a)" self#expression e - | Pmod_extension _ -> assert false + | Pmod_extension e -> self#extension f e method structure f x = self#list ~sep:"@\n" self#structure_item f x method payload f = function + | PStr [{pstr_desc = Pstr_eval (e, attrs)}] -> + pp f "@[<2>%a@]%a" + self#expression e + self#item_attributes attrs | PStr x -> self#structure f x | PTyp x -> pp f ":"; self#core_type f x | PPat (x, None) -> pp f "?"; self#pattern f x @@ -965,7 +1049,7 @@ class printer ()= object(self:'self) pp f " when "; self#expression f e (* transform [f = fun g h -> ..] to [f g h = ... ] could be improved *) - method binding f {pvb_pat=p; pvb_expr=x; pvb_attributes=_} = (* TODO: print attributes *) + method binding f {pvb_pat=p; pvb_expr=x; _} = let rec pp_print_pexp_function f x = if x.pexp_attributes <> [] then pp f "=@;%a" self#expression x else match x.pexp_desc with @@ -983,45 +1067,38 @@ class printer ()= object(self:'self) | ( _ , Ppat_constraint( p ,ty)) -> (* special case for the first*) (match ty.ptyp_desc with | Ptyp_poly _ -> - pp f "%a@;:@;%a=@;%a" self#simple_pattern p self#core_type ty self#expression x + pp f "%a@;:@;%a=@;%a" self#simple_pattern p + self#core_type ty self#expression x | _ -> - pp f "(%a@;:%a)=@;%a" self#simple_pattern p self#core_type ty self#expression x) + pp f "(%a@;:%a)=@;%a" self#simple_pattern p + self#core_type ty self#expression x) | Pexp_constraint (e,t1),Ppat_var {txt;_} -> - pp f "%s:@ %a@;=@;%a" txt self#core_type t1 self#expression e + pp f "%s:@ %a@;=@;%a" txt self#core_type t1 self#expression e | (_, Ppat_var _) -> pp f "%a@ %a" self#simple_pattern p pp_print_pexp_function x | _ -> pp f "%a@;=@;%a" self#pattern p self#expression x (* [in] is not printed *) method bindings f (rf,l) = + let binding kwd rf f x = + pp f "@[<2>%s %a%a@]%a" kwd self#rec_flag rf + self#binding x self#item_attributes x.pvb_attributes + in begin match l with | [] -> () - | [x] -> pp f "@[<2>let %a%a@]" self#rec_flag rf self#binding x + | [x] -> binding "let" rf f x | x::xs -> - (* pp f "@[<hv0>let %a@[<2>%a%a@]" *) - (* FIXME the indentation is not good see [Insert].ml*) - pp f "@[<hv0>@[<2>let %a%a%a@]" - self#rec_flag rf self#binding x - (fun f l -> match l with - | [] -> assert false - | [x] -> - pp f - (* "@]@;and @[<2>%a@]" *) - "@]@;@[<2>and %a@]" - self#binding x - | xs -> - self#list self#binding - (* ~first:"@]@;and @[<2>" *) - ~first:"@]@;@[<2>and " - (* ~sep:"@]@;and @[<2>" *) - ~sep:"@]@;@[<2>and " - ~last:"@]" f xs ) xs + pp f "@[<v>%a@,%a@]" + (binding "let" rf) x + (self#list ~sep:"@," (binding "and" Nonrecursive)) xs end method structure_item f x = begin match x.pstr_desc with - | Pstr_eval (e, _attrs) -> - pp f "@[<hov2>let@ _ =@ %a@]" self#expression e + | Pstr_eval (e, attrs) -> + pp f "@[<hov2>let@ _ =@ %a@]%a" + self#expression e + self#item_attributes attrs | Pstr_type [] -> assert false | Pstr_type l -> self#type_def_list f l | Pstr_value (rf, l) -> (* pp f "@[<hov2>let %a%a@]" self#rec_flag rf self#bindings l *) @@ -1029,31 +1106,36 @@ class printer ()= object(self:'self) | Pstr_typext te -> self#type_extension f te | Pstr_exception ed -> self#exception_declaration f ed | Pstr_module x -> - let rec module_helper me = match me.pmod_desc with - | Pmod_functor(s,mt,me) -> - if mt = None then pp f "()" - else Misc.may (pp f "(%s:%a)" s.txt self#module_type) mt; - module_helper me - | _ -> me in - pp f "@[<hov2>module %s%a@]" + let rec module_helper me = + match me.pmod_desc with + | Pmod_functor(s,mt,me') when me.pmod_attributes = [] -> + if mt = None then pp f "()" + else Misc.may (pp f "(%s:%a)" s.txt self#module_type) mt; + module_helper me' + | _ -> me + in + pp f "@[<hov2>module %s%a@]%a" x.pmb_name.txt (fun f me -> - let me = module_helper me in + let me = module_helper me in (match me.pmod_desc with | Pmod_constraint - (me, + (me', ({pmty_desc=(Pmty_ident (_) - | Pmty_signature (_));_} as mt)) -> - pp f " :@;%a@;=@;%a@;" self#module_type mt self#module_expr me + | Pmty_signature (_));_} as mt)) + when me.pmod_attributes = [] -> + pp f " :@;%a@;=@;%a@;" self#module_type mt self#module_expr me' | _ -> pp f " =@ %a" self#module_expr me )) x.pmb_expr + self#item_attributes x.pmb_attributes | Pstr_open od -> - pp f "@[<2>open%s@;%a@]" + pp f "@[<2>open%s@;%a@]%a" (override od.popen_override) - self#longident_loc od.popen_lid; - | Pstr_modtype {pmtd_name=s; pmtd_type=md} -> - pp f "@[<hov2>module@ type@ %s%a@]" + self#longident_loc od.popen_lid + self#item_attributes od.popen_attributes + | Pstr_modtype {pmtd_name=s; pmtd_type=md; pmtd_attributes=attrs} -> + pp f "@[<hov2>module@ type@ %s%a@]%a" s.txt (fun f md -> match md with | None -> () @@ -1061,85 +1143,103 @@ class printer ()= object(self:'self) pp_print_space f () ; pp f "@ =@ %a" self#module_type mt ) md + self#item_attributes attrs | Pstr_class l -> - let class_declaration f (* for the second will be changed to and FIXME*) - ({pci_params=ls; - pci_name={txt;_}; - pci_virt; - pci_expr={pcl_desc;_}; - _ } as x) = - let rec class_fun_helper f e = match e.pcl_desc with - | Pcl_fun (l, eo, p, e) -> - self#label_exp f (l,eo,p); - class_fun_helper f e - | _ -> e in - pp f "%a%a%s %a" self#virtual_flag pci_virt self#class_params_def ls txt - (fun f _ -> - let ce = - (match pcl_desc with - | Pcl_fun _ -> - class_fun_helper f x.pci_expr; - | _ -> x.pci_expr) in - let ce = - (match ce.pcl_desc with - | Pcl_constraint (ce, ct) -> - pp f ": @[%a@] " self#class_type ct ; - ce - | _ -> ce ) in - pp f "=@;%a" self#class_expr ce ) x in - (match l with - | [] -> () - | [x] -> pp f "@[<2>class %a@]" class_declaration x - | xs -> self#list - ~first:"@[<v0>class @[<2>" - ~sep:"@]@;and @[" - ~last:"@]@]" class_declaration f xs) + let extract_class_args cl = + let rec loop acc cl = + match cl.pcl_desc with + | Pcl_fun (l, eo, p, cl') when cl.pcl_attributes = [] -> + loop ((l,eo,p) :: acc) cl' + | _ -> List.rev acc, cl + in + let args, cl = loop [] cl in + let constr, cl = + match cl.pcl_desc with + | Pcl_constraint (cl', ct) when cl.pcl_attributes = [] -> + Some ct, cl' + | _ -> None, cl + in + args, constr, cl + in + let class_constraint f ct = pp f ": @[%a@] " self#class_type ct in + let class_declaration kwd f + ({pci_params=ls; pci_name={txt;_}; _} as x) = + let args, constr, cl = extract_class_args x.pci_expr in + pp f "@[<2>%s %a%a%s %a%a=@;%a@]%a" kwd + self#virtual_flag x.pci_virt + self#class_params_def ls txt + (self#list self#label_exp) args + (self#option class_constraint) constr + self#class_expr cl + self#item_attributes x.pci_attributes + in begin + match l with + | [] -> () + | [x] -> class_declaration "class" f x + | x :: xs -> + pp f "@[<v>%a@,%a@]" + (class_declaration "class") x + (self#list ~sep:"@," (class_declaration "and")) xs + end | Pstr_class_type (l) -> self#class_type_declaration_list f l ; | Pstr_primitive vd -> - pp f "@[<hov2>external@ %a@ :@ %a@]" protect_ident vd.pval_name.txt - self#value_description vd + pp f "@[<hov2>external@ %a@ :@ %a@]%a" + protect_ident vd.pval_name.txt + self#value_description vd + self#item_attributes vd.pval_attributes | Pstr_include incl -> - pp f "@[<hov2>include@ %a@]" self#module_expr incl.pincl_mod + pp f "@[<hov2>include@ %a@]%a" + self#module_expr incl.pincl_mod + self#item_attributes incl.pincl_attributes | Pstr_recmodule decls -> (* 3.07 *) let aux f = function - | {pmb_name = s; pmb_expr={pmod_desc=Pmod_constraint (expr, typ)}} -> - pp f "@[<hov2>and@ %s:%a@ =@ %a@]" - s.txt self#module_type typ self#module_expr expr + | ({pmb_expr={pmod_desc=Pmod_constraint (expr, typ)}} as pmb) -> + pp f "@[<hov2>and@ %s:%a@ =@ %a@]%a" pmb.pmb_name.txt + self#module_type typ + self#module_expr expr + self#item_attributes pmb.pmb_attributes | _ -> assert false in begin match decls with - | {pmb_name = s; pmb_expr={pmod_desc=Pmod_constraint (expr, typ)}} :: l2 -> - pp f "@[<hv>@[<hov2>module@ rec@ %s:%a@ =@ %a@]@ %a@]" - s.txt + | ({pmb_expr={pmod_desc=Pmod_constraint (expr, typ)}} as pmb) :: l2 -> + pp f "@[<hv>@[<hov2>module@ rec@ %s:%a@ =@ %a@]%a@ %a@]" + pmb.pmb_name.txt self#module_type typ self#module_expr expr + self#item_attributes pmb.pmb_attributes (fun f l2 -> List.iter (aux f) l2) l2 | _ -> assert false end - | Pstr_attribute _ -> () - | Pstr_extension _ -> assert false + | Pstr_attribute a -> self#floating_attribute f a + | Pstr_extension(e, a) -> + self#item_extension f e; + self#item_attributes f a end method type_param f (ct, a) = pp f "%s%a" (type_variance a) self#core_type ct - (* shared by [Pstr_type,Psig_type]*) - method type_def_list f l = - let aux f ({ptype_name = s; ptype_params;ptype_kind;ptype_manifest;_} as td) = - pp f "%a%s%a" - (fun f l -> match l with - |[] -> () - | _ -> pp f "%a@;" (self#list self#type_param ~first:"(" ~last:")" ~sep:",") l) - ptype_params s.txt - (fun f td ->begin match ptype_kind, ptype_manifest with - | Ptype_abstract, None -> () - | _ , _ -> pp f " =@;" end; - pp f "%a" self#type_declaration td ) td in + method type_params f = function + [] -> () + | l -> pp f "%a " (self#list self#type_param ~first:"(" ~last:")" ~sep:",") l + method type_def_list f l = + let type_decl kwd f x = + let eq = + if (x.ptype_kind = Ptype_abstract) + && (x.ptype_manifest = None) then "" + else " =" + in + pp f "@[<2>%s %a%s%s%a@]%a" kwd + self#type_params x.ptype_params + x.ptype_name.txt eq + self#type_declaration x + self#item_attributes x.ptype_attributes + in match l with - | [] -> () ; - | [x] -> pp f "@[<2>type %a@]" aux x - | xs -> pp f "@[<v>@[<2>type %a" - (self#list aux ~sep:"@]@,@[<2>and " ~last:"@]@]") xs - (* called by type_def_list *) + | [] -> assert false + | [x] -> type_decl "type" f x + | x :: xs -> pp f "@[<v>%a@,%a@]" + (type_decl "type") x + (self#list ~sep:"@," (type_decl "and")) xs method record_declaration f lbls = let type_record_field f pld = @@ -1147,46 +1247,65 @@ class printer ()= object(self:'self) pp f "{@\n%a}" (self#list type_record_field ~sep:";@\n" ) lbls - method type_declaration f x = begin - let type_variant_leaf f {pcd_name; pcd_args; pcd_res; pcd_loc=_} = - self#constructor_declaration f (pcd_name.txt, pcd_args, pcd_res) + method type_declaration f x = + let priv f = + match x.ptype_private with + Public -> () + | Private -> pp f "@;private" + in + let manifest f = + match x.ptype_manifest with + | None -> () + | Some y -> pp f "@;%a" self#core_type y + in + let constructor_declaration f pcd = + pp f "|@;"; + self#constructor_declaration f (pcd.pcd_name.txt, pcd.pcd_args, pcd.pcd_res, pcd.pcd_attributes) in - pp f "%a%a@ %a" - (fun f x -> match (x.ptype_manifest,x.ptype_kind,x.ptype_private) with - | (None,_,Public) -> pp f "@;" - | (None,Ptype_abstract,Private) -> pp f "@;" (* private type without print*) - | (None,_,Private) -> pp f "private@;" - | (Some y, Ptype_abstract,Private) -> - pp f "private@;%a" self#core_type y; - | (Some y, _, Private) -> - pp f "%a = private@;" self#core_type y - | (Some y,Ptype_abstract, Public) -> self#core_type f y; - | (Some y, _,Public) -> begin - pp f "%a =@;" self#core_type y (* manifest types*) - end) x - (fun f x -> match x.ptype_kind with - (*here only normal variant types allowed here*) + let label_declaration f pld = + pp f "@[<2>%a%s%a:@;%a;@]" + self#mutable_flag pld.pld_mutable + pld.pld_name.txt + self#attributes pld.pld_attributes + self#core_type pld.pld_type + in + let repr f = + let intro f = + if x.ptype_manifest = None then () + else pp f "@;=" + in + match x.ptype_kind with | Ptype_variant xs -> - pp f "%a" - (self#list ~sep:"" type_variant_leaf) xs + pp f "%t@\n%a" intro + (self#list ~sep:"@\n" constructor_declaration) xs | Ptype_abstract -> () | Ptype_record l -> +(* self#record_declaration f l | Ptype_open -> pp f ".." ) x (self#list (fun f (ct1,ct2,_) -> +*) + pp f "%t@;{@\n%a}" intro + (self#list ~sep:"@\n" label_declaration) l ; + | Ptype_open -> pp f "%t@;.." intro + in + let constraints f = + self#list ~first:"@ " + (fun f (ct1,ct2,_) -> pp f "@[<hov2>constraint@ %a@ =@ %a@]" - self#core_type ct1 self#core_type ct2 )) x.ptype_cstrs ; - (* TODO: attributes *) - end + self#core_type ct1 self#core_type ct2) + f x.ptype_cstrs + in + pp f "%t%t%t%t" priv manifest repr constraints method type_extension f x = let extension_constructor f x = pp f "@\n|@;%a" self#extension_constructor x in - pp f "@[<2>type %a%a +=@;%a@]" + pp f "@[<2>type %a%a +=%a@]%a" (fun f -> function | [] -> () | l -> pp f "%a@;" (self#list self#type_param ~first:"(" ~last:")" ~sep:",") l) @@ -1194,11 +1313,13 @@ class printer ()= object(self:'self) self#longident_loc x.ptyext_path (self#list ~sep:"" extension_constructor) x.ptyext_constructors + self#item_attributes x.ptyext_attributes - method constructor_declaration f (name, args, res) = + method constructor_declaration f (name, args, res, attrs) = match res with | None -> - pp f "%s%a" name + pp f "%s%a%a" name + self#attributes attrs (fun f -> function | Pcstr_tuple [] -> () | Pcstr_tuple l -> @@ -1207,7 +1328,8 @@ class printer ()= object(self:'self) pp f "@;of@;%a" (self#record_declaration) lbls ) args | Some r -> - pp f "%s:@;%a" name + pp f "%s%a:@;%a" name + self#attributes attrs (fun f -> function | Pcstr_tuple [] -> self#core_type1 f r | Pcstr_tuple l -> pp f "%a@;->@;%a" @@ -1224,10 +1346,11 @@ class printer ()= object(self:'self) method extension_constructor f x = match x.pext_kind with | Pext_decl(l, r) -> - self#constructor_declaration f (x.pext_name.txt, l, r) + self#constructor_declaration f (x.pext_name.txt, l, r, x.pext_attributes) | Pext_rebind li -> - pp f "%s@ = @ %a" x.pext_name.txt - self#longident_loc li + pp f "%s%a@;=@;%a" x.pext_name.txt + self#attributes x.pext_attributes + self#longident_loc li method case_list f l : unit = let aux f {pc_lhs; pc_guard; pc_rhs} = diff --git a/parsing/pprintast.mli b/parsing/pprintast.mli index 4f690f98c8..42a3409151 100644 --- a/parsing/pprintast.mli +++ b/parsing/pprintast.mli @@ -37,7 +37,7 @@ class printer : Format.formatter -> Parsetree.class_type_declaration list -> unit method constant : Format.formatter -> Asttypes.constant -> unit method constant_string : Format.formatter -> string -> unit - method constructor_declaration : Format.formatter -> (string * Parsetree.constructor_arguments * Parsetree.core_type option) -> unit + method constructor_declaration : Format.formatter -> (string * Parsetree.constructor_arguments * Parsetree.core_type option * Parsetree.attributes) -> unit method core_type : Format.formatter -> Parsetree.core_type -> unit method core_type1 : Format.formatter -> Parsetree.core_type -> unit method direction_flag : @@ -110,6 +110,8 @@ class printer : Format.formatter -> Parsetree.type_extension -> unit method type_param : Format.formatter -> Parsetree.core_type * Asttypes.variance -> unit + method type_params : + Format.formatter -> (Parsetree.core_type * Asttypes.variance) list -> unit method type_with_label : Format.formatter -> Asttypes.label * Parsetree.core_type -> unit method tyvar : Format.formatter -> string -> unit @@ -120,7 +122,12 @@ class printer : Format.formatter -> Parsetree.value_description -> unit method virtual_flag : Format.formatter -> Asttypes.virtual_flag -> unit method attribute : Format.formatter -> Parsetree.attribute -> unit + method item_attribute : Format.formatter -> Parsetree.attribute -> unit + method floating_attribute : Format.formatter -> Parsetree.attribute -> unit method attributes : Format.formatter -> Parsetree.attributes -> unit + method item_attributes : Format.formatter -> Parsetree.attributes -> unit + method extension : Format.formatter -> Parsetree.extension -> unit + method item_extension : Format.formatter -> Parsetree.extension -> unit end val default : printer val toplevel_phrase : Format.formatter -> Parsetree.toplevel_phrase -> unit diff --git a/parsing/syntaxerr.ml b/parsing/syntaxerr.ml index e239d6fe2a..8c2f37b35d 100644 --- a/parsing/syntaxerr.ml +++ b/parsing/syntaxerr.ml @@ -19,6 +19,7 @@ type error = | Applicative_path of Location.t | Variable_in_scope of Location.t * string | Other of Location.t + | Ill_formed_ast of Location.t * string exception Error of error exception Escape_error @@ -51,6 +52,8 @@ let prepare_error = function var var | Other loc -> Location.error ~loc "Error: Syntax error" + | Ill_formed_ast (loc, s) -> + Location.errorf ~loc "Error: broken invariant in parsetree: %s" s let () = Location.register_error_of_exn @@ -69,4 +72,9 @@ let location_of_error = function | Variable_in_scope(l,_) | Other l | Not_expecting (l, _) + | Ill_formed_ast (l, _) | Expecting (l, _) -> l + + +let ill_formed_ast loc s = + raise (Error (Ill_formed_ast (loc, s))) diff --git a/parsing/syntaxerr.mli b/parsing/syntaxerr.mli index 1aec26ed52..8147213fa4 100644 --- a/parsing/syntaxerr.mli +++ b/parsing/syntaxerr.mli @@ -21,6 +21,7 @@ type error = | Applicative_path of Location.t | Variable_in_scope of Location.t * string | Other of Location.t + | Ill_formed_ast of Location.t * string exception Error of error exception Escape_error @@ -29,3 +30,4 @@ val report_error: formatter -> error -> unit (* Deprecated. Use Location.{error_of_exn, report_error}. *) val location_of_error: error -> Location.t +val ill_formed_ast: Location.t -> string -> 'a diff --git a/stdlib/.depend b/stdlib/.depend index e3a0a671d1..96f95082d2 100644 --- a/stdlib/.depend +++ b/stdlib/.depend @@ -165,8 +165,8 @@ std_exit.cmo : std_exit.cmx : stream.cmo : string.cmi obj.cmi list.cmi lazy.cmi bytes.cmi stream.cmi stream.cmx : string.cmx obj.cmx list.cmx lazy.cmx bytes.cmx stream.cmi -string.cmo : pervasives.cmi obj.cmi bytes.cmi string.cmi -string.cmx : pervasives.cmx obj.cmx bytes.cmx string.cmi +string.cmo : pervasives.cmi list.cmi bytes.cmi string.cmi +string.cmx : pervasives.cmx list.cmx bytes.cmx string.cmi stringLabels.cmo : string.cmi stringLabels.cmi stringLabels.cmx : string.cmx stringLabels.cmi sys.cmo : sys.cmi @@ -291,8 +291,8 @@ std_exit.cmo : std_exit.p.cmx : stream.cmo : string.cmi obj.cmi list.cmi lazy.cmi bytes.cmi stream.cmi stream.p.cmx : string.p.cmx obj.p.cmx list.p.cmx lazy.p.cmx bytes.p.cmx stream.cmi -string.cmo : pervasives.cmi obj.cmi bytes.cmi string.cmi -string.p.cmx : pervasives.p.cmx obj.p.cmx bytes.p.cmx string.cmi +string.cmo : pervasives.cmi list.cmi bytes.cmi string.cmi +string.p.cmx : pervasives.p.cmx list.p.cmx bytes.p.cmx string.cmi stringLabels.cmo : string.cmi stringLabels.cmi stringLabels.p.cmx : string.p.cmx stringLabels.cmi sys.cmo : sys.cmi diff --git a/stdlib/StdlibModules b/stdlib/StdlibModules index a4552ad940..abdfcb3620 100644 --- a/stdlib/StdlibModules +++ b/stdlib/StdlibModules @@ -24,6 +24,8 @@ STDLIB_MODULES=\ bytes \ bytesLabels \ callback \ + camlinternalFormat \ + camlinternalFormatBasics \ camlinternalLazy \ camlinternalMod \ camlinternalOO \ diff --git a/stdlib/array.mli b/stdlib/array.mli index 7c0049e289..e9a64528fe 100644 --- a/stdlib/array.mli +++ b/stdlib/array.mli @@ -47,6 +47,7 @@ external make : int -> 'a -> 'a array = "caml_make_vect" size is only [Sys.max_array_length / 2].*) external create : int -> 'a -> 'a array = "caml_make_vect" + [@@ocaml.deprecated] (** @deprecated [Array.create] is an alias for {!Array.make}. *) val init : int -> (int -> 'a) -> 'a array @@ -73,6 +74,7 @@ val make_matrix : int -> int -> 'a -> 'a array array size is only [Sys.max_array_length / 2]. *) val create_matrix : int -> int -> 'a -> 'a array array + [@@ocaml.deprecated] (** @deprecated [Array.create_matrix] is an alias for {!Array.make_matrix}. *) val append : 'a array -> 'a array -> 'a array diff --git a/stdlib/arrayLabels.mli b/stdlib/arrayLabels.mli index 03b6224ae6..cf8b650e51 100644 --- a/stdlib/arrayLabels.mli +++ b/stdlib/arrayLabels.mli @@ -47,7 +47,8 @@ external make : int -> 'a -> 'a array = "caml_make_vect" size is only [Sys.max_array_length / 2].*) external create : int -> 'a -> 'a array = "caml_make_vect" -(** @deprecated [Array.create] is an alias for {!ArrayLabels.make}. *) + [@@ocaml.deprecated] +(** @deprecated [ArrayLabels.create] is an alias for {!ArrayLabels.make}. *) val init : int -> f:(int -> 'a) -> 'a array (** [Array.init n f] returns a fresh array of length [n], @@ -73,7 +74,8 @@ val make_matrix : dimx:int -> dimy:int -> 'a -> 'a array array size is only [Sys.max_array_length / 2]. *) val create_matrix : dimx:int -> dimy:int -> 'a -> 'a array array -(** @deprecated [Array.create_matrix] is an alias for + [@@ocaml.deprecated] +(** @deprecated [ArrayLabels.create_matrix] is an alias for {!ArrayLabels.make_matrix}. *) val append : 'a array -> 'a array -> 'a array diff --git a/stdlib/buffer.ml b/stdlib/buffer.ml index 2d6f691a27..986fe6f334 100644 --- a/stdlib/buffer.ml +++ b/stdlib/buffer.ml @@ -39,7 +39,7 @@ let blit src srcoff dst dstoff len = || dstoff < 0 || dstoff > (Bytes.length dst) - len then invalid_arg "Buffer.blit" else - Bytes.blit src.buffer srcoff dst dstoff len + Bytes.unsafe_blit src.buffer srcoff dst dstoff len ;; let nth b ofs = @@ -66,6 +66,8 @@ let resize b more = else failwith "Buffer.add: cannot grow buffer" end; let new_buffer = Bytes.create !new_len in + (* PR#6148: let's keep using [blit] rather than [unsafe_blit] in + this tricky function that is slow anyway. *) Bytes.blit b.buffer 0 new_buffer 0 b.position; b.buffer <- new_buffer; b.length <- !new_len @@ -76,25 +78,25 @@ let add_char b c = Bytes.unsafe_set b.buffer pos c; b.position <- pos + 1 -let add_subbytes b s offset len = - if offset < 0 || len < 0 || offset > Bytes.length s - len - then invalid_arg "Buffer.add_subbytes"; +let add_substring b s offset len = + if offset < 0 || len < 0 || offset + len > String.length s + then invalid_arg "Buffer.add_substring/add_subbytes"; let new_position = b.position + len in if new_position > b.length then resize b len; - Bytes.unsafe_blit s offset b.buffer b.position len; + Bytes.blit_string s offset b.buffer b.position len; b.position <- new_position -let add_substring b s offset len = - add_subbytes b (Bytes.unsafe_of_string s) offset len +let add_subbytes b s offset len = + add_substring b (Bytes.unsafe_to_string s) offset len -let add_bytes b s = - let len = Bytes.length s in +let add_string b s = + let len = String.length s in let new_position = b.position + len in if new_position > b.length then resize b len; - Bytes.unsafe_blit s 0 b.buffer b.position len; + Bytes.blit_string s 0 b.buffer b.position len; b.position <- new_position -let add_string b s = add_bytes b (Bytes.unsafe_of_string s) +let add_bytes b s = add_string b (Bytes.unsafe_to_string s) let add_buffer b bs = add_subbytes b bs.buffer 0 bs.position diff --git a/stdlib/buffer.mli b/stdlib/buffer.mli index 855a061667..e7ce8b9999 100644 --- a/stdlib/buffer.mli +++ b/stdlib/buffer.mli @@ -46,9 +46,9 @@ val to_bytes : t -> bytes val sub : t -> int -> int -> string (** [Buffer.sub b off len] returns (a copy of) the bytes from the -current contents of the buffer [b] starting at offset [off] of length -[len] bytes. May raise [Invalid_argument] if out of bounds request. The -buffer itself is unaffected. *) + current contents of the buffer [b] starting at offset [off] of + length [len] bytes. May raise [Invalid_argument] if out of bounds + request. The buffer itself is unaffected. *) val blit : t -> int -> bytes -> int -> int -> unit (** [Buffer.blit src srcoff dst dstoff len] copies [len] characters from @@ -63,7 +63,7 @@ val blit : t -> int -> bytes -> int -> int -> unit val nth : t -> int -> char (** get the n-th character of the buffer. Raise [Invalid_argument] if -index out of bounds *) + index out of bounds *) val length : t -> int (** Return the number of characters currently contained in the buffer. *) diff --git a/stdlib/bytes.ml b/stdlib/bytes.ml index cfcd1ec05e..ece7c1ea5a 100644 --- a/stdlib/bytes.ml +++ b/stdlib/bytes.ml @@ -14,18 +14,22 @@ (* Byte sequence operations *) external length : bytes -> int = "%string_length" +external string_length : string -> int = "%string_length" external get : bytes -> int -> char = "%string_safe_get" external set : bytes -> int -> char -> unit = "%string_safe_set" external create : int -> bytes = "caml_create_string" external unsafe_get : bytes -> int -> char = "%string_unsafe_get" external unsafe_set : bytes -> int -> char -> unit = "%string_unsafe_set" -external unsafe_blit : bytes -> int -> bytes -> int -> int -> unit - = "caml_blit_string" "noalloc" external unsafe_fill : bytes -> int -> int -> char -> unit = "caml_fill_string" "noalloc" external unsafe_to_string : bytes -> string = "%identity" external unsafe_of_string : string -> bytes = "%identity" +external unsafe_blit : bytes -> int -> bytes -> int -> int -> unit + = "caml_blit_string" "noalloc" +external unsafe_blit_string : string -> int -> bytes -> int -> int -> unit + = "caml_blit_string" "noalloc" + let make n c = let s = create n in unsafe_fill s 0 n c; @@ -60,6 +64,14 @@ let sub s ofs len = let sub_string b ofs len = unsafe_to_string (sub b ofs len) +let extend s left right = + let len = length s + left + right in + let r = create len in + let (srcoff, dstoff) = if left < 0 then -left, 0 else 0, left in + let cpylen = min (length s - srcoff) (len - dstoff) in + if cpylen > 0 then unsafe_blit s srcoff r dstoff cpylen; + r + let fill s ofs len c = if ofs < 0 || len < 0 || ofs > length s - len then invalid_arg "Bytes.fill" @@ -71,6 +83,12 @@ let blit s1 ofs1 s2 ofs2 len = then invalid_arg "Bytes.blit" else unsafe_blit s1 ofs1 s2 ofs2 len +let blit_string s1 ofs1 s2 ofs2 len = + if len < 0 || ofs1 < 0 || ofs1 > string_length s1 - len + || ofs2 < 0 || ofs2 > length s2 - len + then invalid_arg "Bytes.blit_string" + else unsafe_blit_string s1 ofs1 s2 ofs2 len + let iter f a = for i = 0 to length a - 1 do f(unsafe_get a i) done @@ -95,6 +113,15 @@ let concat sep l = tl; r +let cat s1 s2 = + let l1 = length s1 in + let l2 = length s2 in + let r = create (l1 + l2) in + unsafe_blit s1 0 r 0 l1; + unsafe_blit s2 0 r l1 l2; + r +;; + external is_printable: char -> bool = "caml_is_printable" external char_code: char -> int = "%identity" external char_chr: int -> char = "%identity" diff --git a/stdlib/bytes.mli b/stdlib/bytes.mli index d9c1046740..82b28a28c5 100644 --- a/stdlib/bytes.mli +++ b/stdlib/bytes.mli @@ -99,6 +99,16 @@ val sub : bytes -> int -> int -> bytes val sub_string : bytes -> int -> int -> string (** Same as [sub] but return a string instead of a byte sequence. *) +val extend : bytes -> int -> int -> bytes +(** [extend s left right] returns a new byte sequence that contains + the bytes of [s], with [left] uninitialized bytes prepended and + [right] uninitialized bytes appended to it. If [left] or [right] + is negative, then bytes are removed (instead of appended) from + the corresponding side of [s]. + + Raise [Invalid_argument] if the result length is negative or + longer than {!Sys.max_string_length} bytes. *) + val fill : bytes -> int -> int -> char -> unit (** [fill s start len c] modifies [s] in place, replacing [len] characters with [c], starting at [start]. @@ -117,10 +127,29 @@ val blit : bytes -> int -> bytes -> int -> int -> unit designate a valid range of [src], or if [dstoff] and [len] do not designate a valid range of [dst]. *) +val blit_string : string -> int -> bytes -> int -> int -> unit +(** [blit src srcoff dst dstoff len] copies [len] bytes from string + [src], starting at index [srcoff], to byte sequence [dst], + starting at index [dstoff]. + + Raise [Invalid_argument] if [srcoff] and [len] do not + designate a valid range of [src], or if [dstoff] and [len] + do not designate a valid range of [dst]. *) + val concat : bytes -> bytes list -> bytes (** [concat sep sl] concatenates the list of byte sequences [sl], inserting the separator byte sequence [sep] between each, and - returns the result as a new byte sequence. *) + returns the result as a new byte sequence. + + Raise [Invalid_argument] if the result is longer than + {!Sys.max_string_length} bytes. *) + +val cat : bytes -> bytes -> bytes +(** [cat s1 s2] concatenates [s1] and [s2] and returns the result + as new byte sequence. + + Raise [Invalid_argument] if the result is longer than + {!Sys.max_string_length} bytes. *) val iter : (char -> unit) -> bytes -> unit (** [iter f s] applies function [f] in turn to all the bytes of [s]. @@ -149,7 +178,10 @@ val trim : bytes -> bytes val escaped : bytes -> bytes (** Return a copy of the argument, with special characters represented - by escape sequences, following the lexical conventions of OCaml. *) + by escape sequences, following the lexical conventions of OCaml. + + Raise [Invalid_argument] if the result is longer than + {!Sys.max_string_length} bytes. *) val index : bytes -> char -> int (** [index s c] returns the index of the first occurrence of byte [c] @@ -223,6 +255,136 @@ val compare: t -> t -> int this function [compare] allows the module [Bytes] to be passed as argument to the functors {!Set.Make} and {!Map.Make}. *) + +(** {4 Unsafe conversions (for advanced users)} + + This section describes unsafe, low-level conversion functions + between [bytes] and [string]. They do not copy the internal data; + used improperly, they can break the immutability invariant on + strings provided by the [-safe-string] option. They are available for + expert library authors, but for most purposes you should use the + always-correct {!Bytes.to_string} and {!Bytes.of_string} instead. +*) + +val unsafe_to_string : bytes -> string +(** Unsafely convert a byte sequence into a string. + + To reason about the use of [unsafe_to_string], it is convenient to + consider an "ownership" discipline. A piece of code that + manipulates some data "owns" it; there are several disjoint ownership + modes, including: + - Unique ownership: the data may be accessed and mutated + - Shared ownership: the data has several owners, that may only + access it, not mutate it. + + Unique ownership is linear: passing the data to another piece of + code means giving up ownership (we cannot write the + data again). A unique owner may decide to make the data shared + (giving up mutation rights on it), but shared data may not become + uniquely-owned again. + + [unsafe_to_string s] can only be used when the caller owns the byte + sequence [s] -- either uniquely or as shared immutable data. The + caller gives up ownership of [s], and gains ownership of the + returned string. + + There are two valid use-cases that respect this ownership + discipline: + + 1. Creating a string by initializing and mutating a byte sequence + that is never changed after initialization is performed. + + {[ +let string_init len f : string = + let s = Bytes.create len in + for i = 0 to len - 1 do Bytes.set s i (f i) done; + Bytes.unsafe_to_string s + ]} + + This function is safe because the byte sequence [s] will never be + accessed or mutated after [unsafe_to_string] is called. The + [string_init] code gives up ownership of [s], and returns the + ownership of the resulting string to its caller. + + Note that it would be unsafe if [s] was passed as an additional + parameter to the function [f] as it could escape this way and be + mutated in the future -- [string_init] would give up ownership of + [s] to pass it to [f], and could not call [unsafe_to_string] + safely. + + We have provided the {!String.init}, {!String.map} and + {!String.mapi} functions to cover most cases of building + new strings. You should prefer those over [to_string] or + [unsafe_to_string] whenever applicable. + + 2. Temporarily giving ownership of a byte sequence to a function + that expects a uniquely owned string and returns ownership back, so + that we can mutate the sequence again after the call ended. + + {[ +let bytes_length (s : bytes) = + String.length (Bytes.unsafe_to_string s) + ]} + + In this use-case, we do not promise that [s] will never be mutated + after the call to [bytes_length s]. The {!String.length} function + temporarily borrows unique ownership of the byte sequence + (and sees it as a [string]), but returns this ownership back to + the caller, which may assume that [s] is still a valid byte + sequence after the call. Note that this is only correct because we + know that {!String.length} does not capture its argument -- it could + escape by a side-channel such as a memoization combinator. + + The caller may not mutate [s] while the string is borrowed (it has + temporarily given up ownership). This affects concurrent programs, + but also higher-order functions: if [String.length] returned + a closure to be called later, [s] should not be mutated until this + closure is fully applied and returns ownership. +*) + +val unsafe_of_string : string -> bytes +(** Unsafely convert a shared string to a byte sequence that should + not be mutated. + + The same ownership discipline that makes [unsafe_to_string] + correct applies to [unsafe_of_string]: you may use it if you were + the owner of the [string] value, and you will own the return + [bytes] in the same mode. + + In practice, unique ownership of string values is extremely + difficult to reason about correctly. You should always assume + strings are shared, never uniquely owned. + + For example, string literals are implicitly shared by the + compiler, so you never uniquely own them. + + {[ +let incorrect = Bytes.unsafe_of_string "hello" +let s = Bytes.of_string "hello" + ]} + + The first declaration is incorrect, because the string literal + ["hello"] could be shared by the compiler with other parts of the + program, and mutating [incorrect] is a bug. You must always use + the second version, which performs a copy and is thus correct. + + Assuming unique ownership of strings that are not string + literals, but are (partly) built from string literals, is also + incorrect. For example, mutating [unsafe_of_string ("foo" ^ s)] + could mutate the shared string ["foo"] -- assuming a rope-like + representation of strings. More generally, functions operating on + strings will assume shared ownership, they do not preserve unique + ownership. It is thus incorrect to assume unique ownership of the + result of [unsafe_of_string]. + + The only case we have reasonable confidence is safe is if the + produced [bytes] is shared -- used as an immutable byte + sequence. This is possibly useful for incremental migration of + low-level programs that manipulate immutable sequences of bytes + (for example {!Marshal.from_bytes}) and previously used the + [string] type for this purpose. +*) + (**/**) (* The following is for system use only. Do not call directly. *) @@ -234,5 +396,3 @@ external unsafe_blit : = "caml_blit_string" "noalloc" external unsafe_fill : bytes -> int -> int -> char -> unit = "caml_fill_string" "noalloc" -external unsafe_to_string : bytes -> string = "%identity" -external unsafe_of_string : string -> bytes = "%identity" diff --git a/stdlib/bytesLabels.mli b/stdlib/bytesLabels.mli index 23ccaf3911..d48d95f5c7 100644 --- a/stdlib/bytesLabels.mli +++ b/stdlib/bytesLabels.mli @@ -112,6 +112,11 @@ val map : f:(char -> char) -> bytes -> bytes stores the resulting bytes in a new sequence that is returned as the result. *) +val mapi : f:(int -> char -> char) -> bytes -> bytes +(** [mapi f s] calls [f] with each character of [s] and its + index (in increasing index order) and stores the resulting bytes + in a new sequence that is returned as the result. *) + val trim : bytes -> bytes (** Return a copy of the argument, without leading and trailing whitespace. The bytes regarded as whitespace are the ASCII @@ -204,5 +209,5 @@ external unsafe_blit : unit = "caml_blit_string" "noalloc" external unsafe_fill : bytes -> pos:int -> len:int -> char -> unit = "caml_fill_string" "noalloc" -external unsafe_to_string : bytes -> string = "%identity" -external unsafe_of_string : string -> bytes = "%identity" +val unsafe_to_string : bytes -> string +val unsafe_of_string : string -> bytes diff --git a/stdlib/camlinternalFormat.ml b/stdlib/camlinternalFormat.ml index f28e05f180..5dda3a7fc6 100644 --- a/stdlib/camlinternalFormat.ml +++ b/stdlib/camlinternalFormat.ml @@ -1,19 +1,5 @@ open CamlinternalFormatBasics -let legacy_behavior = true -(** When this flag is enabled, the format parser tries to behave as - the <4.02 implementations, in particular it ignores most benine - nonsensical format. When the flag is disabled, it will reject any - format that is not accepted by the specification. - - A typical example would be "%+ d": specifying both '+' (if the - number is positive, pad with a '+' to get the same width as - negative numbres) and ' ' (if the number is positive, pad with - a space) does not make sense, but the legacy (< 4.02) - implementation was happy to just ignore the space. -*) - - (******************************************************************************) (* Tools to manipulate scanning set of chars (see %[...]) *) @@ -120,13 +106,15 @@ type ('b, 'c) acc_formatting_gen = (* Reversed list of printing atoms. *) (* Used to accumulate printf arguments. *) and ('b, 'c) acc = - | Acc_formatting_lit of ('b, 'c) acc * formatting_lit(* Special fmtting (box) *) + | Acc_formatting_lit of ('b, 'c) acc * formatting_lit (* Special fmtting (box) *) | Acc_formatting_gen of ('b, 'c) acc * ('b, 'c) acc_formatting_gen (* Special fmtting (box) *) - | Acc_string of ('b, 'c) acc * string (* Literal or generated string*) - | Acc_char of ('b, 'c) acc * char (* Literal or generated char *) - | Acc_delay of ('b, 'c) acc * ('b -> 'c) (* Delayed printing (%a, %t) *) - | Acc_flush of ('b, 'c) acc (* Flush *) - | Acc_invalid_arg of ('b, 'c) acc * string (* Raise Invalid_argument msg *) + | Acc_string_literal of ('b, 'c) acc * string (* Literal string *) + | Acc_char_literal of ('b, 'c) acc * char (* Literal char *) + | Acc_data_string of ('b, 'c) acc * string (* Generated string *) + | Acc_data_char of ('b, 'c) acc * char (* Generated char *) + | Acc_delay of ('b, 'c) acc * ('b -> 'c) (* Delayed printing (%a, %t) *) + | Acc_flush of ('b, 'c) acc (* Flush *) + | Acc_invalid_arg of ('b, 'c) acc * string (* Raise Invalid_argument msg *) | End_of_acc (* List of heterogeneous values. *) @@ -1363,11 +1351,11 @@ let rec make_printf : type a b c d e f . fun k o acc fmt -> match fmt with | Char rest -> fun c -> - let new_acc = Acc_char (acc, c) in + let new_acc = Acc_data_char (acc, c) in make_printf k o new_acc rest | Caml_char rest -> fun c -> - let new_acc = Acc_string (acc, format_caml_char c) in + let new_acc = Acc_data_string (acc, format_caml_char c) in make_printf k o new_acc rest | String (pad, rest) -> make_string_padding k o acc rest pad (fun str -> str) @@ -1384,7 +1372,7 @@ fun k o acc fmt -> match fmt with | Float (fconv, pad, prec, rest) -> make_float_padding_precision k o acc rest pad prec fconv | Bool rest -> - fun b -> make_printf k o (Acc_string (acc, string_of_bool b)) rest + fun b -> make_printf k o (Acc_data_string (acc, string_of_bool b)) rest | Alpha rest -> fun f x -> make_printf k o (Acc_delay (acc, fun o -> f o x)) rest | Theta rest -> @@ -1403,15 +1391,15 @@ fun k o acc fmt -> match fmt with make_printf k o (Acc_flush acc) rest | String_literal (str, rest) -> - make_printf k o (Acc_string (acc, str)) rest + make_printf k o (Acc_string_literal (acc, str)) rest | Char_literal (chr, rest) -> - make_printf k o (Acc_char (acc, chr)) rest + make_printf k o (Acc_char_literal (acc, chr)) rest | Format_arg (_, sub_fmtty, rest) -> let ty = string_of_fmtty sub_fmtty in (fun str -> ignore str; - make_printf k o (Acc_string (acc, ty)) rest) + make_printf k o (Acc_data_string (acc, ty)) rest) | Format_subst (_, fmtty, rest) -> fun (Format (fmt, _)) -> make_printf k o acc (concat_fmt (recast fmt fmtty) rest) @@ -1424,7 +1412,7 @@ fun k o acc fmt -> match fmt with (* Accepted for backward compatibility. *) (* Interpret %l, %n and %L as %u. *) fun n -> - let new_acc = Acc_string (acc, format_int "%u" n) in + let new_acc = Acc_data_string (acc, format_int "%u" n) in make_printf k o new_acc rest | Ignored_param (ign, rest) -> make_ignored_param k o acc ign rest @@ -1507,15 +1495,15 @@ and make_string_padding : type x z a b c d e f . fun k o acc fmt pad trans -> match pad with | No_padding -> fun x -> - let new_acc = Acc_string (acc, trans x) in + let new_acc = Acc_data_string (acc, trans x) in make_printf k o new_acc fmt | Lit_padding (padty, width) -> fun x -> - let new_acc = Acc_string (acc, fix_padding padty width (trans x)) in + let new_acc = Acc_data_string (acc, fix_padding padty width (trans x)) in make_printf k o new_acc fmt | Arg_padding padty -> fun w x -> - let new_acc = Acc_string (acc, fix_padding padty w (trans x)) in + let new_acc = Acc_data_string (acc, fix_padding padty w (trans x)) in make_printf k o new_acc fmt (* Fix padding and precision for int, int32, nativeint or int64. *) @@ -1529,39 +1517,39 @@ and make_int_padding_precision : type x y z a b c d e f . | No_padding, No_precision -> fun x -> let str = trans iconv x in - make_printf k o (Acc_string (acc, str)) fmt + make_printf k o (Acc_data_string (acc, str)) fmt | No_padding, Lit_precision p -> fun x -> let str = fix_int_precision p (trans iconv x) in - make_printf k o (Acc_string (acc, str)) fmt + make_printf k o (Acc_data_string (acc, str)) fmt | No_padding, Arg_precision -> fun p x -> let str = fix_int_precision p (trans iconv x) in - make_printf k o (Acc_string (acc, str)) fmt + make_printf k o (Acc_data_string (acc, str)) fmt | Lit_padding (padty, w), No_precision -> fun x -> let str = fix_padding padty w (trans iconv x) in - make_printf k o (Acc_string (acc, str)) fmt + make_printf k o (Acc_data_string (acc, str)) fmt | Lit_padding (padty, w), Lit_precision p -> fun x -> let str = fix_padding padty w (fix_int_precision p (trans iconv x)) in - make_printf k o (Acc_string (acc, str)) fmt + make_printf k o (Acc_data_string (acc, str)) fmt | Lit_padding (padty, w), Arg_precision -> fun p x -> let str = fix_padding padty w (fix_int_precision p (trans iconv x)) in - make_printf k o (Acc_string (acc, str)) fmt + make_printf k o (Acc_data_string (acc, str)) fmt | Arg_padding padty, No_precision -> fun w x -> let str = fix_padding padty w (trans iconv x) in - make_printf k o (Acc_string (acc, str)) fmt + make_printf k o (Acc_data_string (acc, str)) fmt | Arg_padding padty, Lit_precision p -> fun w x -> let str = fix_padding padty w (fix_int_precision p (trans iconv x)) in - make_printf k o (Acc_string (acc, str)) fmt + make_printf k o (Acc_data_string (acc, str)) fmt | Arg_padding padty, Arg_precision -> fun w p x -> let str = fix_padding padty w (fix_int_precision p (trans iconv x)) in - make_printf k o (Acc_string (acc, str)) fmt + make_printf k o (Acc_data_string (acc, str)) fmt (* Convert a float, fix padding and precision if needed. *) (* Take the float argument and one or two extra integer arguments if needed. *) @@ -1573,41 +1561,41 @@ and make_float_padding_precision : type x y a b c d e f . | No_padding, No_precision -> fun x -> let str = convert_float fconv default_float_precision x in - make_printf k o (Acc_string (acc, str)) fmt + make_printf k o (Acc_data_string (acc, str)) fmt | No_padding, Lit_precision p -> fun x -> let str = convert_float fconv p x in - make_printf k o (Acc_string (acc, str)) fmt + make_printf k o (Acc_data_string (acc, str)) fmt | No_padding, Arg_precision -> fun p x -> let str = convert_float fconv p x in - make_printf k o (Acc_string (acc, str)) fmt + make_printf k o (Acc_data_string (acc, str)) fmt | Lit_padding (padty, w), No_precision -> fun x -> let str = convert_float fconv default_float_precision x in let str' = fix_padding padty w str in - make_printf k o (Acc_string (acc, str')) fmt + make_printf k o (Acc_data_string (acc, str')) fmt | Lit_padding (padty, w), Lit_precision p -> fun x -> let str = fix_padding padty w (convert_float fconv p x) in - make_printf k o (Acc_string (acc, str)) fmt + make_printf k o (Acc_data_string (acc, str)) fmt | Lit_padding (padty, w), Arg_precision -> fun p x -> let str = fix_padding padty w (convert_float fconv p x) in - make_printf k o (Acc_string (acc, str)) fmt + make_printf k o (Acc_data_string (acc, str)) fmt | Arg_padding padty, No_precision -> fun w x -> let str = convert_float fconv default_float_precision x in let str' = fix_padding padty w str in - make_printf k o (Acc_string (acc, str')) fmt + make_printf k o (Acc_data_string (acc, str')) fmt | Arg_padding padty, Lit_precision p -> fun w x -> let str = fix_padding padty w (convert_float fconv p x) in - make_printf k o (Acc_string (acc, str)) fmt + make_printf k o (Acc_data_string (acc, str)) fmt | Arg_padding padty, Arg_precision -> fun w p x -> let str = fix_padding padty w (convert_float fconv p x) in - make_printf k o (Acc_string (acc, str)) fmt + make_printf k o (Acc_data_string (acc, str)) fmt (******************************************************************************) (* Continuations for make_printf *) @@ -1623,8 +1611,10 @@ let rec output_acc o acc = match acc with output_acc o p; output_string o "@{"; output_acc o acc'; | Acc_formatting_gen (p, Acc_open_box acc') -> output_acc o p; output_string o "@["; output_acc o acc'; - | Acc_string (p, s) -> output_acc o p; output_string o s - | Acc_char (p, c) -> output_acc o p; output_char o c + | Acc_string_literal (p, s) + | Acc_data_string (p, s) -> output_acc o p; output_string o s + | Acc_char_literal (p, c) + | Acc_data_char (p, c) -> output_acc o p; output_char o c | Acc_delay (p, f) -> output_acc o p; f o | Acc_flush p -> output_acc o p; flush o | Acc_invalid_arg (p, msg) -> output_acc o p; invalid_arg msg; @@ -1641,8 +1631,10 @@ let rec bufput_acc b acc = match acc with bufput_acc b p; Buffer.add_string b "@{"; bufput_acc b acc'; | Acc_formatting_gen (p, Acc_open_box acc') -> bufput_acc b p; Buffer.add_string b "@["; bufput_acc b acc'; - | Acc_string (p, s) -> bufput_acc b p; Buffer.add_string b s - | Acc_char (p, c) -> bufput_acc b p; Buffer.add_char b c + | Acc_string_literal (p, s) + | Acc_data_string (p, s) -> bufput_acc b p; Buffer.add_string b s + | Acc_char_literal (p, c) + | Acc_data_char (p, c) -> bufput_acc b p; Buffer.add_char b c | Acc_delay (p, f) -> bufput_acc b p; f b | Acc_flush p -> bufput_acc b p; | Acc_invalid_arg (p, msg) -> bufput_acc b p; invalid_arg msg; @@ -1660,8 +1652,10 @@ let rec strput_acc b acc = match acc with strput_acc b p; Buffer.add_string b "@{"; strput_acc b acc'; | Acc_formatting_gen (p, Acc_open_box acc') -> strput_acc b p; Buffer.add_string b "@["; strput_acc b acc'; - | Acc_string (p, s) -> strput_acc b p; Buffer.add_string b s - | Acc_char (p, c) -> strput_acc b p; Buffer.add_char b c + | Acc_string_literal (p, s) + | Acc_data_string (p, s) -> strput_acc b p; Buffer.add_string b s + | Acc_char_literal (p, c) + | Acc_data_char (p, c) -> strput_acc b p; Buffer.add_char b c | Acc_delay (p, f) -> strput_acc b p; Buffer.add_string b (f ()) | Acc_flush p -> strput_acc b p; | Acc_invalid_arg (p, msg) -> strput_acc b p; invalid_arg msg; @@ -1761,7 +1755,7 @@ fun pad prec fmt -> (* Parse a string representing a format and create a fmt_ebb. *) (* Raise an Failure exception in case of invalid format. *) -let fmt_ebb_of_string str = +let fmt_ebb_of_string ?legacy_behavior str = (* Parameters naming convention: *) (* - lit_start: start of the literal sequence. *) (* - str_ind: current index in the string. *) @@ -1778,6 +1772,22 @@ let fmt_ebb_of_string str = (* - symb: char representing the conversion ('c', 's', 'd', ...). *) (* - char_set: set of characters as bitmap (see scanf %[...]). *) + let legacy_behavior = match legacy_behavior with + | Some flag -> flag + | None -> true + (** When this flag is enabled, the format parser tries to behave as + the <4.02 implementations, in particular it ignores most benine + nonsensical format. When the flag is disabled, it will reject any + format that is not accepted by the specification. + + A typical example would be "%+ d": specifying both '+' (if the + number is positive, pad with a '+' to get the same width as + negative numbres) and ' ' (if the number is positive, pad with + a space) does not make sense, but the legacy (< 4.02) + implementation was happy to just ignore the space. + *) + in + (* Raise a Failure with a friendly error message. *) (* Used when the end of the format (or the current sub-format) was encoutered unexpectedly. *) @@ -1824,6 +1834,7 @@ let fmt_ebb_of_string str = and parse_ign : type e f . int -> int -> int -> (_, _, e, f) fmt_ebb = fun pct_ind str_ind end_ind -> + if str_ind = end_ind then unexpected_end_of_format end_ind; match str.[str_ind] with | '_' -> parse_flags pct_ind (str_ind+1) end_ind true | _ -> parse_flags pct_ind str_ind end_ind false @@ -1912,6 +1923,7 @@ let fmt_ebb_of_string str = if str_ind = end_ind then unexpected_end_of_format end_ind; let parse_literal str_ind = let new_ind, prec = parse_positive str_ind end_ind 0 in + if new_ind = end_ind then unexpected_end_of_format end_ind; parse_conversion pct_ind (new_ind + 1) end_ind plus sharp space ign pad (Lit_precision prec) str.[new_ind] in match str.[str_ind] with @@ -2409,6 +2421,7 @@ let fmt_ebb_of_string str = parse_char_set_content (str_ind + 1) end_ind in let str_ind, reverse = + if str_ind = end_ind then unexpected_end_of_format end_ind; match str.[str_ind] with | '^' -> str_ind + 1, true | _ -> str_ind, false in diff --git a/stdlib/camlinternalFormat.mli b/stdlib/camlinternalFormat.mli index 728dc865ac..dd8da62d2b 100644 --- a/stdlib/camlinternalFormat.mli +++ b/stdlib/camlinternalFormat.mli @@ -25,8 +25,10 @@ type ('b, 'c) acc_formatting_gen = and ('b, 'c) acc = | Acc_formatting_lit of ('b, 'c) acc * formatting_lit | Acc_formatting_gen of ('b, 'c) acc * ('b, 'c) acc_formatting_gen - | Acc_string of ('b, 'c) acc * string - | Acc_char of ('b, 'c) acc * char + | Acc_string_literal of ('b, 'c) acc * string + | Acc_char_literal of ('b, 'c) acc * char + | Acc_data_string of ('b, 'c) acc * string + | Acc_data_char of ('b, 'c) acc * char | Acc_delay of ('b, 'c) acc * ('b -> 'c) | Acc_flush of ('b, 'c) acc | Acc_invalid_arg of ('b, 'c) acc * string @@ -53,7 +55,11 @@ val type_format : ('a, 'b, 'c, 'd, 'e, 'f) CamlinternalFormatBasics.fmtty -> ('a, 'b, 'c, 'd, 'e, 'f) CamlinternalFormatBasics.fmt -val fmt_ebb_of_string : string -> ('b, 'c, 'e, 'f) fmt_ebb +val fmt_ebb_of_string : ?legacy_behavior:bool -> string -> ('b, 'c, 'e, 'f) fmt_ebb +(* warning: the optional flag legacy_behavior is EXPERIMENTAL and will + be removed in the next version. You must not set it explicitly. It + is only used by the type-checker implementation. +*) val format_of_string_fmtty : string -> diff --git a/stdlib/camlinternalOO.ml b/stdlib/camlinternalOO.ml index 872a56065b..3c39c0b672 100644 --- a/stdlib/camlinternalOO.ml +++ b/stdlib/camlinternalOO.ml @@ -128,7 +128,7 @@ let rec fit_size n = let new_table pub_labels = incr table_count; let len = Array.length pub_labels in - let methods = Array.create (len*2+2) dummy_met in + let methods = Array.make (len*2+2) dummy_met in methods.(0) <- magic len; methods.(1) <- magic (fit_size len * Sys.word_size / 8 - 1); for i = 0 to len - 1 do methods.(i*2+3) <- magic pub_labels.(i) done; @@ -144,7 +144,7 @@ let new_table pub_labels = let resize array new_size = let old_size = Array.length array.methods in if new_size > old_size then begin - let new_buck = Array.create new_size dummy_met in + let new_buck = Array.make new_size dummy_met in Array.blit array.methods 0 new_buck 0 old_size; array.methods <- new_buck end @@ -267,7 +267,7 @@ let to_array arr = let new_methods_variables table meths vals = let meths = to_array meths in let nmeths = Array.length meths and nvals = Array.length vals in - let res = Array.create (nmeths + nvals) 0 in + let res = Array.make (nmeths + nvals) 0 in for i = 0 to nmeths - 1 do res.(i) <- get_method_label table meths.(i) done; diff --git a/stdlib/filename.mli b/stdlib/filename.mli index c44c6d954a..a4ea3aaab3 100644 --- a/stdlib/filename.mli +++ b/stdlib/filename.mli @@ -117,14 +117,13 @@ val set_temp_dir_name : string -> unit @since 4.00.0 *) -val temp_dir_name : string -(** @deprecated The name of the initial temporary directory: +val temp_dir_name : string [@@ocaml.deprecated] +(** The name of the initial temporary directory: Under Unix, the value of the [TMPDIR] environment variable, or "/tmp" if the variable is not set. Under Windows, the value of the [TEMP] environment variable, or "." if the variable is not set. - This function is deprecated; {!Filename.get_temp_dir_name} should be - used instead. + @deprecated You should use {!Filename.get_temp_dir_name} instead. @since 3.09.1 *) diff --git a/stdlib/format.ml b/stdlib/format.ml index 55674d179b..5e206e11f6 100644 --- a/stdlib/format.ml +++ b/stdlib/format.ml @@ -1070,10 +1070,10 @@ let compute_tag output tag_acc = else Buffer.sub buf 1 (len - 2) (************************************************************** - + Defining continuations to be passed as arguments of CamlinternalFormat.make_printf. - + **************************************************************) open CamlinternalFormatBasics @@ -1097,10 +1097,12 @@ let output_formatting_lit ppf fmting_lit = match fmting_lit with (* Differ from Printf.output_acc by the interpretation of formatting. *) (* Used as a continuation of CamlinternalFormat.make_printf. *) let rec output_acc ppf acc = match acc with - | Acc_string (Acc_formatting_lit (p, Magic_size (_, size)), s) -> + | Acc_string_literal (Acc_formatting_lit (p, Magic_size (_, size)), s) + | Acc_data_string (Acc_formatting_lit (p, Magic_size (_, size)), s) -> output_acc ppf p; pp_print_as_size ppf (size_of_int size) s; - | Acc_char (Acc_formatting_lit (p, Magic_size (_, size)), c) -> + | Acc_char_literal (Acc_formatting_lit (p, Magic_size (_, size)), c) + | Acc_data_char (Acc_formatting_lit (p, Magic_size (_, size)), c) -> output_acc ppf p; pp_print_as_size ppf (size_of_int size) (String.make 1 c); | Acc_formatting_lit (p, f) -> @@ -1113,8 +1115,10 @@ let rec output_acc ppf acc = match acc with let () = output_acc ppf p in let (indent, bty) = open_box_of_string (compute_tag output_acc acc') in pp_open_box_gen ppf indent bty - | Acc_string (p, s) -> output_acc ppf p; pp_print_string ppf s; - | Acc_char (p, c) -> output_acc ppf p; pp_print_char ppf c; + | Acc_string_literal (p, s) + | Acc_data_string (p, s) -> output_acc ppf p; pp_print_string ppf s; + | Acc_char_literal (p, c) + | Acc_data_char (p, c) -> output_acc ppf p; pp_print_char ppf c; | Acc_delay (p, f) -> output_acc ppf p; f ppf; | Acc_flush p -> output_acc ppf p; pp_print_flush ppf (); | Acc_invalid_arg (p, msg) -> output_acc ppf p; invalid_arg msg; @@ -1125,10 +1129,12 @@ let rec output_acc ppf acc = match acc with (* Differ from Printf.bufput_acc by the interpretation of formatting. *) (* Used as a continuation of CamlinternalFormat.make_printf. *) let rec strput_acc ppf acc = match acc with - | Acc_string (Acc_formatting_lit (p, Magic_size (_, size)), s) -> + | Acc_string_literal (Acc_formatting_lit (p, Magic_size (_, size)), s) + | Acc_data_string (Acc_formatting_lit (p, Magic_size (_, size)), s) -> strput_acc ppf p; pp_print_as_size ppf (size_of_int size) s; - | Acc_char (Acc_formatting_lit (p, Magic_size (_, size)), c) -> + | Acc_char_literal (Acc_formatting_lit (p, Magic_size (_, size)), c) + | Acc_data_char (Acc_formatting_lit (p, Magic_size (_, size)), c) -> strput_acc ppf p; pp_print_as_size ppf (size_of_int size) (String.make 1 c); | Acc_delay (Acc_formatting_lit (p, Magic_size (_, size)), f) -> @@ -1144,8 +1150,10 @@ let rec strput_acc ppf acc = match acc with let () = strput_acc ppf p in let (indent, bty) = open_box_of_string (compute_tag strput_acc acc') in pp_open_box_gen ppf indent bty - | Acc_string (p, s) -> strput_acc ppf p; pp_print_string ppf s; - | Acc_char (p, c) -> strput_acc ppf p; pp_print_char ppf c; + | Acc_string_literal (p, s) + | Acc_data_string (p, s) -> strput_acc ppf p; pp_print_string ppf s; + | Acc_char_literal (p, c) + | Acc_data_char (p, c) -> strput_acc ppf p; pp_print_char ppf c; | Acc_delay (p, f) -> strput_acc ppf p; pp_print_string ppf (f ()); | Acc_flush p -> strput_acc ppf p; pp_print_flush ppf (); | Acc_invalid_arg (p, msg) -> strput_acc ppf p; invalid_arg msg; @@ -1181,7 +1189,7 @@ let sprintf fmt = let asprintf (Format (fmt, _)) = let b = Buffer.create 512 in - let ppf = formatter_of_buffer b in + let ppf = formatter_of_buffer b in let k' : (formatter -> (formatter, unit) acc -> string) = fun ppf acc -> output_acc ppf acc; diff --git a/stdlib/format.mli b/stdlib/format.mli index e7cbe506e6..b44fc0a946 100644 --- a/stdlib/format.mli +++ b/stdlib/format.mli @@ -714,14 +714,18 @@ val ksprintf : (string -> 'a) -> ('b, unit, string, 'a) format4 -> 'b;; (** {6 Deprecated} *) -val bprintf : Buffer.t -> ('a, formatter, unit) format -> 'a;; +val bprintf : Buffer.t -> ('a, formatter, unit) format -> 'a + [@@ocaml.deprecated] +;; (** @deprecated This function is error prone. Do not use it. If you need to print to some buffer [b], you must first define a formatter writing to [b], using [let to_b = formatter_of_buffer b]; then use regular calls to [Format.fprintf] on formatter [to_b]. *) -val kprintf : (string -> 'a) -> ('b, unit, string, 'a) format4 -> 'b;; +val kprintf : (string -> 'a) -> ('b, unit, string, 'a) format4 -> 'b + [@@ocaml.deprecated] +;; (** @deprecated An alias for [ksprintf]. *) val set_all_formatter_output_functions : @@ -730,6 +734,7 @@ val set_all_formatter_output_functions : newline:(unit -> unit) -> spaces:(int -> unit) -> unit +[@@ocaml.deprecated] ;; (** @deprecated Subsumed by [set_formatter_out_functions]. *) @@ -740,12 +745,14 @@ val get_all_formatter_output_functions : (unit -> unit) * (unit -> unit) * (int -> unit) +[@@ocaml.deprecated] ;; (** @deprecated Subsumed by [get_formatter_out_functions]. *) val pp_set_all_formatter_output_functions : formatter -> out:(string -> int -> int -> unit) -> flush:(unit -> unit) -> newline:(unit -> unit) -> spaces:(int -> unit) -> unit +[@@ocaml.deprecated] ;; (** @deprecated Subsumed by [pp_set_formatter_out_functions]. *) @@ -754,6 +761,7 @@ val pp_get_all_formatter_output_functions : formatter -> unit -> (string -> int -> int -> unit) * (unit -> unit) * (unit -> unit) * (int -> unit) +[@@ocaml.deprecated] ;; (** @deprecated Subsumed by [pp_get_formatter_out_functions]. *) diff --git a/stdlib/gc.mli b/stdlib/gc.mli index c4ed399300..3400ff3422 100644 --- a/stdlib/gc.mli +++ b/stdlib/gc.mli @@ -83,7 +83,7 @@ type stat = type control = { mutable minor_heap_size : int; (** The size (in words) of the minor heap. Changing - this parameter will trigger a minor collection. Default: 32k. *) + this parameter will trigger a minor collection. Default: 262k. *) mutable major_heap_increment : int; (** How much to add to the major heap when increasing it. If this @@ -131,7 +131,7 @@ type control = mutable stack_limit : int; (** The maximum size of the stack (in words). This is only relevant to the byte-code runtime, as the native code runtime - uses the operating system's stack. Default: 256k. *) + uses the operating system's stack. Default: 1024k. *) mutable allocation_policy : int; (** The policy used for allocating in the heap. Possible @@ -215,6 +215,9 @@ val finalise : ('a -> unit) -> 'a -> unit before the values it depends upon. Of course, this becomes false if additional dependencies are introduced by assignments. + In the presence of multiple OCaml threads it should be assumed that + any particular finaliser may be executed in any of the threads. + Anything reachable from the closure of finalisation functions is considered reachable, so the following code will not work as expected: diff --git a/stdlib/header.c b/stdlib/header.c index cb3d9953a3..93cdfeb2dc 100644 --- a/stdlib/header.c +++ b/stdlib/header.c @@ -133,7 +133,7 @@ static char * read_runtime_path(int fd) char buffer[TRAILER_SIZE]; static char runtime_path[MAXPATHLEN]; int num_sections, i; - uint32 path_size; + uint32_t path_size; long ofs; lseek(fd, (long) -TRAILER_SIZE, SEEK_END); diff --git a/stdlib/lazy.mli b/stdlib/lazy.mli index 6108a715cd..6ade2e3d46 100644 --- a/stdlib/lazy.mli +++ b/stdlib/lazy.mli @@ -75,11 +75,11 @@ val is_val : 'a t -> bool;; did not raise an exception. @since 4.00.0 *) -val lazy_from_fun : (unit -> 'a) -> 'a t;; +val lazy_from_fun : (unit -> 'a) -> 'a t [@@ocaml.deprecated];; (** @deprecated synonym for [from_fun]. *) -val lazy_from_val : 'a -> 'a t;; +val lazy_from_val : 'a -> 'a t [@@ocaml.deprecated];; (** @deprecated synonym for [from_val]. *) -val lazy_is_val : 'a t -> bool;; +val lazy_is_val : 'a t -> bool [@@ocaml.deprecated];; (** @deprecated synonym for [is_val]. *) diff --git a/stdlib/list.mli b/stdlib/list.mli index 5b88f229db..b53a63c646 100644 --- a/stdlib/list.mli +++ b/stdlib/list.mli @@ -112,14 +112,14 @@ val fold_right : ('a -> 'b -> 'b) -> 'a list -> 'b -> 'b val iter2 : ('a -> 'b -> unit) -> 'a list -> 'b list -> unit (** [List.iter2 f [a1; ...; an] [b1; ...; bn]] calls in turn [f a1 b1; ...; f an bn]. - Raise [Invalid_argument] if the two lists have - different lengths. *) + Raise [Invalid_argument] if the two lists are determined + to have different lengths. *) val map2 : ('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list (** [List.map2 f [a1; ...; an] [b1; ...; bn]] is [[f a1 b1; ...; f an bn]]. - Raise [Invalid_argument] if the two lists have - different lengths. Not tail-recursive. *) + Raise [Invalid_argument] if the two lists are determined + to have different lengths. Not tail-recursive. *) val rev_map2 : ('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list (** [List.rev_map2 f l1 l2] gives the same result as @@ -129,14 +129,14 @@ 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 (** [List.fold_left2 f a [b1; ...; bn] [c1; ...; cn]] is [f (... (f (f a b1 c1) b2 c2) ...) bn cn]. - Raise [Invalid_argument] if the two lists have - different lengths. *) + Raise [Invalid_argument] if the two lists are determined + to have different lengths. *) val fold_right2 : ('a -> 'b -> 'c -> 'c) -> 'a list -> 'b list -> 'c -> 'c (** [List.fold_right2 f [a1; ...; an] [b1; ...; bn] c] is [f a1 b1 (f a2 b2 (... (f an bn c) ...))]. - Raise [Invalid_argument] if the two lists have - different lengths. Not tail-recursive. *) + Raise [Invalid_argument] if the two lists are determined + to have different lengths. Not tail-recursive. *) (** {6 List scanning} *) @@ -154,13 +154,13 @@ val exists : ('a -> bool) -> 'a list -> bool val for_all2 : ('a -> 'b -> bool) -> 'a list -> 'b list -> bool (** Same as {!List.for_all}, but for a two-argument predicate. - Raise [Invalid_argument] if the two lists have - different lengths. *) + Raise [Invalid_argument] if the two lists are determined + to have different lengths. *) val exists2 : ('a -> 'b -> bool) -> 'a list -> 'b list -> bool (** Same as {!List.exists}, but for a two-argument predicate. - Raise [Invalid_argument] if the two lists have - different lengths. *) + Raise [Invalid_argument] if the two lists are determined + to have different lengths. *) val mem : 'a -> 'a list -> bool (** [mem a l] is true if and only if [a] is equal diff --git a/stdlib/listLabels.mli b/stdlib/listLabels.mli index 8cf6514718..45e3c41ea1 100644 --- a/stdlib/listLabels.mli +++ b/stdlib/listLabels.mli @@ -112,14 +112,14 @@ val fold_right : f:('a -> 'b -> 'b) -> 'a list -> init:'b -> 'b val iter2 : f:('a -> 'b -> unit) -> 'a list -> 'b list -> unit (** [List.iter2 f [a1; ...; an] [b1; ...; bn]] calls in turn [f a1 b1; ...; f an bn]. - Raise [Invalid_argument] if the two lists have - different lengths. *) + Raise [Invalid_argument] if the two lists are determined + to have different lengths. *) val map2 : f:('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list (** [List.map2 f [a1; ...; an] [b1; ...; bn]] is [[f a1 b1; ...; f an bn]]. - Raise [Invalid_argument] if the two lists have - different lengths. Not tail-recursive. *) + Raise [Invalid_argument] if the two lists are determined + to have different lengths. Not tail-recursive. *) val rev_map2 : f:('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list (** [List.rev_map2 f l1 l2] gives the same result as @@ -130,15 +130,15 @@ val fold_left2 : f:('a -> 'b -> 'c -> 'a) -> init:'a -> 'b list -> 'c list -> 'a (** [List.fold_left2 f a [b1; ...; bn] [c1; ...; cn]] is [f (... (f (f a b1 c1) b2 c2) ...) bn cn]. - Raise [Invalid_argument] if the two lists have - different lengths. *) + Raise [Invalid_argument] if the two lists are determined + to have different lengths. *) val fold_right2 : f:('a -> 'b -> 'c -> 'c) -> 'a list -> 'b list -> init:'c -> 'c (** [List.fold_right2 f [a1; ...; an] [b1; ...; bn] c] is [f a1 b1 (f a2 b2 (... (f an bn c) ...))]. - Raise [Invalid_argument] if the two lists have - different lengths. Not tail-recursive. *) + Raise [Invalid_argument] if the two lists are determined + to have different lengths. Not tail-recursive. *) (** {6 List scanning} *) @@ -156,13 +156,13 @@ val exists : f:('a -> bool) -> 'a list -> bool val for_all2 : f:('a -> 'b -> bool) -> 'a list -> 'b list -> bool (** Same as {!ListLabels.for_all}, but for a two-argument predicate. - Raise [Invalid_argument] if the two lists have - different lengths. *) + Raise [Invalid_argument] if the two lists are determined + to have different lengths. *) val exists2 : f:('a -> 'b -> bool) -> 'a list -> 'b list -> bool (** Same as {!ListLabels.exists}, but for a two-argument predicate. - Raise [Invalid_argument] if the two lists have - different lengths. *) + Raise [Invalid_argument] if the two lists are determined + to have different lengths. *) val mem : 'a -> set:'a list -> bool (** [mem a l] is true if and only if [a] is equal diff --git a/stdlib/marshal.ml b/stdlib/marshal.ml index 4f59a3ef21..4155595711 100644 --- a/stdlib/marshal.ml +++ b/stdlib/marshal.ml @@ -32,6 +32,12 @@ let to_buffer buff ofs len v flags = then invalid_arg "Marshal.to_buffer: substring out of bounds" else to_buffer_unsafe buff ofs len v flags +(* The functions below use byte sequences as input, never using any + mutation. It makes sense to use non-mutated [bytes] rather than + [string], because we really work with sequences of bytes, not + a text representation. +*) + external from_channel: in_channel -> 'a = "caml_input_value" external from_bytes_unsafe: bytes -> int -> 'a = "caml_input_value_from_string" @@ -54,4 +60,7 @@ let from_bytes buff ofs = else from_bytes_unsafe buff ofs end -let from_string buff ofs = from_bytes (Bytes.unsafe_of_string buff) ofs +let from_string buff ofs = + (* Bytes.unsafe_of_string is safe here, as the produced byte + sequence is never mutated *) + from_bytes (Bytes.unsafe_of_string buff) ofs diff --git a/stdlib/marshal.mli b/stdlib/marshal.mli index 37f0345b38..9dfdd1624c 100644 --- a/stdlib/marshal.mli +++ b/stdlib/marshal.mli @@ -140,7 +140,8 @@ val from_bytes : bytes -> int -> 'a (** [Marshal.from_bytes buff ofs] unmarshals a structured value like {!Marshal.from_channel} does, except that the byte representation is not read from a channel, but taken from - the byte sequence [buff], starting at position [ofs]. *) + the byte sequence [buff], starting at position [ofs]. + The byte sequence is not mutated. *) val from_string : string -> int -> 'a (** Same as [from_bytes] but take a string as argument instead of a diff --git a/stdlib/nativeint.mli b/stdlib/nativeint.mli index eb2dde2cf7..3dce1b6c49 100644 --- a/stdlib/nativeint.mli +++ b/stdlib/nativeint.mli @@ -16,8 +16,8 @@ This module provides operations on the type [nativeint] of signed 32-bit integers (on 32-bit platforms) or signed 64-bit integers (on 64-bit platforms). - This integer type has exactly the same width as that of a [long] - integer type in the C compiler. All arithmetic operations over + This integer type has exactly the same width as that of a + pointer type in the C compiler. All arithmetic operations over [nativeint] are taken modulo 2{^32} or 2{^64} depending on the word size of the architecture. diff --git a/stdlib/obj.ml b/stdlib/obj.ml index d054d35c42..ac9695cdb8 100644 --- a/stdlib/obj.ml +++ b/stdlib/obj.ml @@ -81,3 +81,8 @@ let extension_id x = let slot = extension_slot x in (obj (field slot 1) : int) with Not_found -> invalid_arg "Obj.extension_id" + +let extension_slot x = + try + extension_slot x + with Not_found -> invalid_arg "Obj.extension_slot" diff --git a/stdlib/obj.mli b/stdlib/obj.mli index 5181e2a22b..08b8a4f64b 100644 --- a/stdlib/obj.mli +++ b/stdlib/obj.mli @@ -55,6 +55,7 @@ val unaligned_tag : int (* should never happen @since 3.11.0 *) val extension_name : 'a -> string val extension_id : 'a -> int +val extension_slot : 'a -> t (** The following two functions are deprecated. Use module {!Marshal} instead. *) diff --git a/stdlib/parsing.ml b/stdlib/parsing.ml index 762128244c..47e151e1b4 100644 --- a/stdlib/parsing.ml +++ b/stdlib/parsing.ml @@ -84,10 +84,10 @@ external set_trace: bool -> bool = "caml_set_parser_trace" let env = - { s_stack = Array.create 100 0; - v_stack = Array.create 100 (Obj.repr ()); - symb_start_stack = Array.create 100 dummy_pos; - symb_end_stack = Array.create 100 dummy_pos; + { s_stack = Array.make 100 0; + v_stack = Array.make 100 (Obj.repr ()); + symb_start_stack = Array.make 100 dummy_pos; + symb_end_stack = Array.make 100 dummy_pos; stacksize = 100; stackbase = 0; curr_char = 0; @@ -104,10 +104,10 @@ let env = let grow_stacks() = let oldsize = env.stacksize in let newsize = oldsize * 2 in - let new_s = Array.create newsize 0 - and new_v = Array.create newsize (Obj.repr ()) - and new_start = Array.create newsize dummy_pos - and new_end = Array.create newsize dummy_pos in + let new_s = Array.make newsize 0 + and new_v = Array.make newsize (Obj.repr ()) + and new_start = Array.make newsize dummy_pos + and new_end = Array.make newsize dummy_pos in Array.blit env.s_stack 0 new_s 0 oldsize; env.s_stack <- new_s; Array.blit env.v_stack 0 new_v 0 oldsize; diff --git a/stdlib/pervasives.ml b/stdlib/pervasives.ml index 8f9e423f95..6b7165206e 100644 --- a/stdlib/pervasives.ml +++ b/stdlib/pervasives.ml @@ -290,6 +290,8 @@ let flush_all () = external unsafe_output : out_channel -> bytes -> int -> int -> unit = "caml_ml_output" +external unsafe_output_string : out_channel -> string -> int -> int -> unit + = "caml_ml_output" external output_char : out_channel -> char -> unit = "caml_ml_output_char" @@ -297,7 +299,7 @@ let output_bytes oc s = unsafe_output oc s 0 (bytes_length s) let output_string oc s = - unsafe_output oc (bytes_unsafe_of_string s) 0 (string_length s) + unsafe_output_string oc s 0 (string_length s) let output oc s ofs len = if ofs < 0 || len < 0 || ofs > bytes_length s - len @@ -305,7 +307,9 @@ let output oc s ofs len = else unsafe_output oc s ofs len let output_substring oc s ofs len = - output oc (bytes_unsafe_of_string s) ofs len + if ofs < 0 || len < 0 || ofs > string_length s - len + then invalid_arg "output_substring" + else unsafe_output_string oc s ofs len external output_byte : out_channel -> int -> unit = "caml_ml_output_char" external output_binary_int : out_channel -> int -> unit = "caml_ml_output_int" diff --git a/stdlib/pervasives.mli b/stdlib/pervasives.mli index 77cb1e92ce..d471a4ebb6 100644 --- a/stdlib/pervasives.mli +++ b/stdlib/pervasives.mli @@ -130,6 +130,7 @@ external ( && ) : bool -> bool -> bool = "%sequand" [e2] is not evaluated at all. *) external ( & ) : bool -> bool -> bool = "%sequand" + [@@ocaml.deprecated] (** @deprecated {!Pervasives.( && )} should be used instead. *) external ( || ) : bool -> bool -> bool = "%sequor" @@ -138,6 +139,7 @@ external ( || ) : bool -> bool -> bool = "%sequor" [e2] is not evaluated at all. *) external ( or ) : bool -> bool -> bool = "%sequor" + [@@ocaml.deprecated] (** @deprecated {!Pervasives.( || )} should be used instead.*) (** {6 Debugging} *) diff --git a/stdlib/scanf.ml b/stdlib/scanf.ml index c21de72484..2a63ced9a4 100644 --- a/stdlib/scanf.ml +++ b/stdlib/scanf.ml @@ -1038,7 +1038,8 @@ fun k fmt -> match fmt with | Formatting_gen (Open_box (Format (fmt, _)), rest) -> take_format_readers k (concat_fmt fmt rest) | Format_arg (_, _, rest) -> take_format_readers k rest - | Format_subst (_, fmtty, rest) -> take_fmtty_format_readers k (erase_rel (symm fmtty)) rest + | Format_subst (_, fmtty, rest) -> + take_fmtty_format_readers k (erase_rel (symm fmtty)) rest | Ignored_param (ign, rest) -> take_ignored_format_readers k ign rest | End_of_format -> k Nil diff --git a/stdlib/sort.mli b/stdlib/sort.mli index d5abb79fa8..a9be27e138 100644 --- a/stdlib/sort.mli +++ b/stdlib/sort.mli @@ -20,11 +20,13 @@ *) val list : ('a -> 'a -> bool) -> 'a list -> 'a list + [@@ocaml.deprecated] (** Sort a list in increasing order according to an ordering predicate. The predicate should return [true] if its first argument is less than or equal to its second argument. *) val array : ('a -> 'a -> bool) -> 'a array -> unit + [@@ocaml.deprecated] (** Sort an array in increasing order according to an ordering predicate. The predicate should return [true] if its first argument is @@ -32,6 +34,7 @@ val array : ('a -> 'a -> bool) -> 'a array -> unit The array is sorted in place. *) val merge : ('a -> 'a -> bool) -> 'a list -> 'a list -> 'a list + [@@ocaml.deprecated] (** Merge two lists according to the given predicate. Assuming the two argument lists are sorted according to the predicate, [merge] returns a sorted list containing the elements diff --git a/stdlib/string.ml b/stdlib/string.ml index 00ff8be9e7..93880af268 100644 --- a/stdlib/string.ml +++ b/stdlib/string.ml @@ -39,8 +39,8 @@ let sub s ofs len = B.sub (bos s) ofs len |> bts let fill = B.fill -let blit s1 ofs1 s2 ofs2 len = - B.blit (bos s1) ofs1 s2 ofs2 len +let blit = + B.blit_string let concat sep l = match l with diff --git a/stdlib/string.mli b/stdlib/string.mli index da6d8351af..8f1e178b53 100644 --- a/stdlib/string.mli +++ b/stdlib/string.mli @@ -90,8 +90,11 @@ val init : int -> (int -> char) -> string @since 4.02.0 *) -val copy : string -> string -(** Return a copy of the given string. *) +val copy : string -> string [@@ocaml.deprecated] +(** Return a copy of the given string. + + @deprecated Because strings are immutable, it doesn't make much + sense to make identical copies of them. *) val sub : string -> int -> int -> string (** [String.sub s start len] returns a fresh string of length [len], @@ -111,17 +114,14 @@ val fill : bytes -> int -> int -> char -> unit [@@ocaml.deprecated] @deprecated This is a deprecated alias of {!Bytes.fill}.[ ] *) val blit : string -> int -> bytes -> int -> int -> unit -(** [String.blit src srcoff dst dstoff len] copies [len] characters - (bytes) from the string [src], starting at index [srcoff], to byte - sequence [dst], starting at index [dstoff]. - - Raise [Invalid_argument] if [srcoff] and [len] do not - designate a valid substring of [src], or if [dstoff] and [len] - do not designate a valid range of [dst]. *) +(** Same as {!Bytes.blit_string}. *) val concat : string -> string list -> string (** [String.concat sep sl] concatenates the list of strings [sl], - inserting the separator string [sep] between each. *) + inserting the separator string [sep] between each. + + Raise [Invalid_argument] if the result is longer than + {!Sys.max_string_length} bytes. *) val iter : (char -> unit) -> string -> unit (** [String.iter f s] applies function [f] in turn to all @@ -159,7 +159,10 @@ val escaped : string -> string represented by escape sequences, following the lexical conventions of OCaml. If there is no special character in the argument, return the original string itself, - not a copy. Its inverse function is Scanf.unescaped. *) + not a copy. Its inverse function is Scanf.unescaped. + + Raise [Invalid_argument] if the result is longer than + {!Sys.max_string_length} bytes. *) val index : string -> char -> int (** [String.index s c] returns the index of the first diff --git a/stdlib/stringLabels.mli b/stdlib/stringLabels.mli index dcef6db036..1cf5d51ede 100644 --- a/stdlib/stringLabels.mli +++ b/stdlib/stringLabels.mli @@ -104,6 +104,12 @@ val map : f:(char -> char) -> string -> string is returned. @since 4.00.0 *) +val mapi : f:(int -> char -> char) -> string -> string +(** [String.mapi f s] calls [f] with each character of [s] and its + index (in increasing index order) and stores the results in a new + string that is returned. + @since 4.02.0 *) + val trim : string -> string (** Return a copy of the argument, without leading and trailing whitespace. The characters regarded as whitespace are: [' '], diff --git a/stdlib/sys.mli b/stdlib/sys.mli index 0f3b131ada..ae175c2e81 100644 --- a/stdlib/sys.mli +++ b/stdlib/sys.mli @@ -11,7 +11,12 @@ (* *) (***********************************************************************) -(** System interface. *) +(** System interface. + + Every function in this module raises [Sys_error] with an + informative message when the underlying system call signal + an error. +*) val argv : string array (** The command line arguments given to the process. diff --git a/stdlib/weak.ml b/stdlib/weak.ml index 536a42e047..8166142b66 100644 --- a/stdlib/weak.ml +++ b/stdlib/weak.ml @@ -80,8 +80,8 @@ module Make (H : Hashtbl.HashedType) : (S with type data = H.t) = struct let sz = if sz < 7 then 7 else sz in let sz = if sz > Sys.max_array_length then Sys.max_array_length else sz in { - table = Array.create sz emptybucket; - hashes = Array.create sz [| |]; + table = Array.make sz emptybucket; + hashes = Array.make sz [| |]; limit = limit; oversize = 0; rover = 0; diff --git a/testsuite/interactive/lib-gc/alloc.ml b/testsuite/interactive/lib-gc/alloc.ml index 2db8034690..aadecab28e 100644 --- a/testsuite/interactive/lib-gc/alloc.ml +++ b/testsuite/interactive/lib-gc/alloc.ml @@ -21,7 +21,7 @@ let l = 32768;; let m = 1000;; -let ar = Array.create l "";; +let ar = Array.make l "";; Random.init 1234;; diff --git a/testsuite/interactive/lib-graph-3/sorts.ml b/testsuite/interactive/lib-graph-3/sorts.ml index 126463d2cb..6e00d25663 100644 --- a/testsuite/interactive/lib-graph-3/sorts.ml +++ b/testsuite/interactive/lib-graph-3/sorts.ml @@ -75,7 +75,7 @@ let initialize name array maxval x y w h = (* Main animation function *) let display functs nelts maxval = - let a = Array.create nelts 0 in + let a = Array.make nelts 0 in for i = 0 to nelts - 1 do a.(i) <- Random.int maxval done; diff --git a/testsuite/tests/asmcomp/mainarith.c b/testsuite/tests/asmcomp/mainarith.c index f935391b58..d102c16dc3 100644 --- a/testsuite/tests/asmcomp/mainarith.c +++ b/testsuite/tests/asmcomp/mainarith.c @@ -33,25 +33,29 @@ double F, G; #define INTTEST(arg,res) \ { intnat result = (res); \ if (arg != result) \ - printf("Failed test \"%s == %s\" for X=%"FMT"d and Y=%"FMT"d: result %"FMT"d, expected %"FMT"d\n", \ + printf("Failed test \"%s == %s\" for X=%"FMT"d and Y=%"FMT"d: " \ + "result %"FMT"d, expected %"FMT"d\n", \ #arg, #res, X, Y, arg, result); \ } #define INTFLOATTEST(arg,res) \ { intnat result = (res); \ if (arg != result) \ - printf("Failed test \"%s == %s\" for F=%.15g and G=%.15g: result %"FMT"d, expected %"FMT"d\n", \ + printf("Failed test \"%s == %s\" for F=%.15g and G=%.15g: "\ + "result %"FMT"d, expected %"FMT"d\n", \ #arg, #res, F, G, arg, result); \ } #define FLOATTEST(arg,res) \ { double result = (res); \ if (arg < result || arg > result) \ - printf("Failed test \"%s == %s\" for F=%.15g and G=%.15g: result %.15g, expected %.15g\n", \ + printf("Failed test \"%s == %s\" for F=%.15g and G=%.15g: "\ + "result %.15g, expected %.15g\n", \ #arg, #res, F, G, arg, result); \ } #define FLOATINTTEST(arg,res) \ { double result = (res); \ if (arg < result || arg > result) \ - printf("Failed test \"%s == %s\" for X=%"FMT"d and Y=%"FMT"d: result %.15g, expected %.15g\n", \ + printf("Failed test \"%s == %s\" for X=%"FMT"d and Y=%"FMT"d: "\ + "result %.15g, expected %.15g\n", \ #arg, #res, X, Y, arg, result); \ } diff --git a/testsuite/tests/asmcomp/optargs.ml b/testsuite/tests/asmcomp/optargs.ml index a4f4040703..92705bd25e 100644 --- a/testsuite/tests/asmcomp/optargs.ml +++ b/testsuite/tests/asmcomp/optargs.ml @@ -1,3 +1,15 @@ +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Alain Frisch, LexiFi *) +(* *) +(* Copyright 2014 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + (* Check the effectiveness of inlining the wrapper which fills in default values for optional arguments. diff --git a/testsuite/tests/asmcomp/parsecmm.mly b/testsuite/tests/asmcomp/parsecmm.mly index c81ca619b6..e936c25879 100644 --- a/testsuite/tests/asmcomp/parsecmm.mly +++ b/testsuite/tests/asmcomp/parsecmm.mly @@ -24,9 +24,9 @@ let rec make_letdef def body = Clet(id, def, make_letdef rem body) let make_switch n selector caselist = - let index = Array.create n 0 in + let index = Array.make n 0 in let casev = Array.of_list caselist in - let actv = Array.create (Array.length casev) (Cexit(0,[])) in + let actv = Array.make (Array.length casev) (Cexit(0,[])) in for i = 0 to Array.length casev - 1 do let (posl, e) = casev.(i) in List.iter (fun pos -> index.(pos) <- i) posl; diff --git a/testsuite/tests/asmcomp/staticalloc.ml b/testsuite/tests/asmcomp/staticalloc.ml index e21fdee633..3186686c7b 100644 --- a/testsuite/tests/asmcomp/staticalloc.ml +++ b/testsuite/tests/asmcomp/staticalloc.ml @@ -1,3 +1,15 @@ +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Alain Frisch, LexiFi *) +(* *) +(* Copyright 2014 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + (* Check the effectiveness of structured constant propagation and static allocation. diff --git a/testsuite/tests/basic-modules/Makefile b/testsuite/tests/basic-modules/Makefile new file mode 100644 index 0000000000..62dbc2a690 --- /dev/null +++ b/testsuite/tests/basic-modules/Makefile @@ -0,0 +1,19 @@ +######################################################################### +# # +# OCaml # +# # +# Xavier Clerc, SED, INRIA Rocquencourt # +# # +# Copyright 2010 Institut National de Recherche en Informatique et # +# en Automatique. All rights reserved. This file is distributed # +# under the terms of the Q Public License version 1.0. # +# # +######################################################################### + +BASEDIR=../.. + +MODULES=offset +MAIN_MODULE=main + +include $(BASEDIR)/makefiles/Makefile.one +include $(BASEDIR)/makefiles/Makefile.common diff --git a/testsuite/tests/basic-modules/main.ml b/testsuite/tests/basic-modules/main.ml new file mode 100644 index 0000000000..54f8cbd61d --- /dev/null +++ b/testsuite/tests/basic-modules/main.ml @@ -0,0 +1,13 @@ +(* PR#6435 *) + +module F (M : sig + type t + module Set : Set.S with type elt = t + end) = +struct + let test set = Printf.printf "%d\n" (M.Set.cardinal set) +end + +module M = F (Offset) + +let () = M.test (Offset.M.Set.singleton "42") diff --git a/testsuite/tests/basic-modules/main.reference b/testsuite/tests/basic-modules/main.reference new file mode 100644 index 0000000000..d00491fd7e --- /dev/null +++ b/testsuite/tests/basic-modules/main.reference @@ -0,0 +1 @@ +1 diff --git a/testsuite/tests/basic-modules/offset.ml b/testsuite/tests/basic-modules/offset.ml new file mode 100644 index 0000000000..457947dcd5 --- /dev/null +++ b/testsuite/tests/basic-modules/offset.ml @@ -0,0 +1,10 @@ +module M = struct + type t = string + + let x = 0 + let x = 1 + + module Set = Set.Make(String) +end + +include M diff --git a/testsuite/tests/basic/arrays.ml b/testsuite/tests/basic/arrays.ml index e123edff61..b56893f5e0 100644 --- a/testsuite/tests/basic/arrays.ml +++ b/testsuite/tests/basic/arrays.ml @@ -79,7 +79,7 @@ let test3 () = and t2 = AbstractFloat.from_float 2.0 and t3 = AbstractFloat.from_float 3.0 in let v = [|t1;t2;t3|] in - let w = Array.create 2 t1 in + let w = Array.make 2 t1 in let u = Array.copy v in if not (AbstractFloat.to_float v.(0) = 1.0 && AbstractFloat.to_float v.(1) = 2.0 && diff --git a/testsuite/tests/lib-dynlink-bytecode/stub1.c b/testsuite/tests/lib-dynlink-bytecode/stub1.c index f97c66f3e8..60c8ab35ae 100644 --- a/testsuite/tests/lib-dynlink-bytecode/stub1.c +++ b/testsuite/tests/lib-dynlink-bytecode/stub1.c @@ -16,8 +16,9 @@ #include <stdio.h> value stub1() { + CAMLparam0(); CAMLlocal1(x); printf("This is stub1!\n"); fflush(stdout); x = caml_copy_string("ABCDEF"); - return x; + CAMLreturn(x); } diff --git a/testsuite/tests/lib-threads/test1.ml b/testsuite/tests/lib-threads/test1.ml index 8961b6f857..c551fbc5dd 100644 --- a/testsuite/tests/lib-threads/test1.ml +++ b/testsuite/tests/lib-threads/test1.ml @@ -21,7 +21,7 @@ type 'a prodcons = notfull: Condition.t } let create size init = - { buffer = Array.create size init; + { buffer = Array.make size init; lock = Mutex.create(); readpos = 0; writepos = 0; diff --git a/testsuite/tests/lib-threads/testsocket.ml b/testsuite/tests/lib-threads/testsocket.ml index 4b41e0b937..6b2b0b0495 100644 --- a/testsuite/tests/lib-threads/testsocket.ml +++ b/testsuite/tests/lib-threads/testsocket.ml @@ -33,11 +33,11 @@ let main() = match Sys.argv with | [| _ |] -> false, [| Sys.argv.(0); "caml.inria.fr" |] | _ -> true, Sys.argv in - let addresses = Array.create (Array.length argv - 1) inet_addr_any in + let addresses = Array.make (Array.length argv - 1) inet_addr_any in for i = 1 to Array.length argv - 1 do addresses.(i - 1) <- (gethostbyname argv.(i)).h_addr_list.(0) done; - let processes = Array.create (Array.length addresses) (Thread.self()) in + let processes = Array.make (Array.length addresses) (Thread.self()) in for i = 0 to Array.length addresses - 1 do processes.(i) <- Thread.create (engine verbose i) addresses.(i) done; diff --git a/testsuite/tests/lib-threads/token1.ml b/testsuite/tests/lib-threads/token1.ml index d6e7a1b7ab..d0a7528b08 100644 --- a/testsuite/tests/lib-threads/token1.ml +++ b/testsuite/tests/lib-threads/token1.ml @@ -39,7 +39,7 @@ let process (n, conds, nprocs) = let main() = let nprocs = try int_of_string Sys.argv.(1) with _ -> 100 in let iter = try int_of_string Sys.argv.(2) with _ -> 1000 in - let conds = Array.create nprocs (Condition.create()) in + let conds = Array.make nprocs (Condition.create()) in for i = 1 to nprocs - 1 do conds.(i) <- Condition.create() done; niter := iter; for i = 0 to nprocs - 1 do Thread.create process (i, conds, nprocs) done; diff --git a/testsuite/tests/lib-threads/token2.ml b/testsuite/tests/lib-threads/token2.ml index 9ef05806ef..c3548fb0f2 100644 --- a/testsuite/tests/lib-threads/token2.ml +++ b/testsuite/tests/lib-threads/token2.ml @@ -35,9 +35,9 @@ let process (n, ins, outs, nprocs) = let main() = let nprocs = try int_of_string Sys.argv.(1) with _ -> 100 in let iter = try int_of_string Sys.argv.(2) with _ -> 1000 in - let ins = Array.create nprocs Unix.stdin in - let outs = Array.create nprocs Unix.stdout in - let threads = Array.create nprocs (Thread.self ()) in + let ins = Array.make nprocs Unix.stdin in + let outs = Array.make nprocs Unix.stdout in + let threads = Array.make nprocs (Thread.self ()) in for n = 0 to nprocs - 1 do let (i, o) = Unix.pipe() in ins.(n) <- i; outs.(n) <- o done; diff --git a/testsuite/tests/misc-unsafe/fft.ml b/testsuite/tests/misc-unsafe/fft.ml index 2c1cf38b0f..7e2442b0b0 100644 --- a/testsuite/tests/misc-unsafe/fft.ml +++ b/testsuite/tests/misc-unsafe/fft.ml @@ -135,8 +135,8 @@ let test np = print_int np; print_string "... "; flush stdout; let enp = float np in let npm = np / 2 - 1 in - let pxr = Array.create (np+2) 0.0 - and pxi = Array.create (np+2) 0.0 in + let pxr = Array.make (np+2) 0.0 + and pxi = Array.make (np+2) 0.0 in let t = pi /. enp in pxr.(1) <- (enp -. 1.0) *. 0.5; pxi.(1) <- 0.0; diff --git a/testsuite/tests/misc-unsafe/quicksort.ml b/testsuite/tests/misc-unsafe/quicksort.ml index 4f872fd24a..8879d95291 100644 --- a/testsuite/tests/misc-unsafe/quicksort.ml +++ b/testsuite/tests/misc-unsafe/quicksort.ml @@ -63,8 +63,8 @@ let random() = exception Failed let test_sort sort_fun size = - let a = Array.create size 0 in - let check = Array.create 4096 0 in + let a = Array.make size 0 in + let check = Array.make 4096 0 in for i = 0 to size-1 do let n = random() in a.(i) <- n; check.(n) <- check.(n)+1 done; diff --git a/testsuite/tests/misc/bdd.ml b/testsuite/tests/misc/bdd.ml index 954edc1648..297eb68e45 100644 --- a/testsuite/tests/misc/bdd.ml +++ b/testsuite/tests/misc/bdd.ml @@ -31,14 +31,14 @@ let getId bdd = let initSize_1 = 8*1024 - 1 let nodeC = ref 1 let sz_1 = ref initSize_1 -let htab = ref(Array.create (!sz_1+1) []) +let htab = ref(Array.make (!sz_1+1) []) let n_items = ref 0 let hashVal x y v = x lsl 1 + y + v lsl 2 let resize newSize = let arr = !htab in let newSz_1 = newSize-1 in - let newArr = Array.create newSize [] in + let newArr = Array.make newSize [] in let rec copyBucket bucket = match bucket with [] -> () @@ -71,7 +71,7 @@ let rec insert idl idh v ind bucket newNode = let resetUnique () = ( sz_1 := initSize_1; - htab := Array.create (!sz_1+1) []; + htab := Array.make (!sz_1+1) []; n_items := 0; nodeC := 1 ) @@ -111,14 +111,14 @@ let mkVar x = mkNode zero x one let cacheSize = 1999 -let andslot1 = Array.create cacheSize 0 -let andslot2 = Array.create cacheSize 0 -let andslot3 = Array.create cacheSize zero -let xorslot1 = Array.create cacheSize 0 -let xorslot2 = Array.create cacheSize 0 -let xorslot3 = Array.create cacheSize zero -let notslot1 = Array.create cacheSize 0 -let notslot2 = Array.create cacheSize one +let andslot1 = Array.make cacheSize 0 +let andslot2 = Array.make cacheSize 0 +let andslot3 = Array.make cacheSize zero +let xorslot1 = Array.make cacheSize 0 +let xorslot2 = Array.make cacheSize 0 +let xorslot3 = Array.make cacheSize zero +let notslot1 = Array.make cacheSize 0 +let notslot2 = Array.make cacheSize one let hash x y = ((x lsl 1)+y) mod cacheSize let rec not n = @@ -196,7 +196,7 @@ let random() = seed := !seed * 25173 + 17431; !seed land 1 > 0 let random_vars n = - let vars = Array.create n false in + let vars = Array.make n false in for i = 0 to n - 1 do vars.(i) <- random() done; vars diff --git a/testsuite/tests/tool-debugger/.ignore b/testsuite/tests/tool-debugger/basic/.ignore index e09cf9eb6e..e09cf9eb6e 100644 --- a/testsuite/tests/tool-debugger/.ignore +++ b/testsuite/tests/tool-debugger/basic/.ignore diff --git a/testsuite/tests/tool-debugger/Makefile b/testsuite/tests/tool-debugger/basic/Makefile index f95b4803b6..f95b4803b6 100644 --- a/testsuite/tests/tool-debugger/Makefile +++ b/testsuite/tests/tool-debugger/basic/Makefile diff --git a/testsuite/tests/tool-debugger/debuggee.ml b/testsuite/tests/tool-debugger/basic/debuggee.ml index 341d0b369f..341d0b369f 100644 --- a/testsuite/tests/tool-debugger/debuggee.ml +++ b/testsuite/tests/tool-debugger/basic/debuggee.ml diff --git a/testsuite/tests/tool-debugger/debuggee.reference b/testsuite/tests/tool-debugger/basic/debuggee.reference index e998926c3d..e998926c3d 100644 --- a/testsuite/tests/tool-debugger/debuggee.reference +++ b/testsuite/tests/tool-debugger/basic/debuggee.reference diff --git a/testsuite/tests/tool-debugger/input_script b/testsuite/tests/tool-debugger/basic/input_script index 2caf06dd4d..2caf06dd4d 100755 --- a/testsuite/tests/tool-debugger/input_script +++ b/testsuite/tests/tool-debugger/basic/input_script diff --git a/testsuite/tests/tool-debugger/find-artifacts/.ignore b/testsuite/tests/tool-debugger/find-artifacts/.ignore new file mode 100644 index 0000000000..0a2c0c40cf --- /dev/null +++ b/testsuite/tests/tool-debugger/find-artifacts/.ignore @@ -0,0 +1,2 @@ +compiler-libs +out diff --git a/testsuite/tests/tool-debugger/find-artifacts/Makefile b/testsuite/tests/tool-debugger/find-artifacts/Makefile new file mode 100644 index 0000000000..f313d86424 --- /dev/null +++ b/testsuite/tests/tool-debugger/find-artifacts/Makefile @@ -0,0 +1,67 @@ +######################################################################### +# # +# OCaml # +# # +# Damien Doligez, EPI Gallium, INRIA Rocquencourt # +# # +# Copyright 2013 Institut National de Recherche en Informatique et # +# en Automatique. All rights reserved. This file is distributed # +# under the terms of the Q Public License version 1.0. # +# # +######################################################################### + +BASEDIR=../../.. +MAIN_MODULE=debuggee +ADD_COMPFLAGS=-g -custom +LD_PATH=$(TOPDIR)/otherlibs/$(UNIXLIBVAR)unix + +.PHONY: default +default: + @if ! $(SUPPORTS_SHARED_LIBRARIES); then \ + echo 'skipped (shared libraries not available)'; \ + else \ + $(MAKE) compile; \ + $(SET_LD_PATH) OCAMLLIB=. $(MAKE) run; \ + fi + +.PHONY: compile +compile: $(ML_FILES) $(CMO_FILES) + @rm -rf out + @rm -f program.byte program.byte.exe + @mkdir out + @$(OCAMLC) $(ADD_COMPFLAGS) $(ADD_CFLAGS) -o out/blah.cmo -c \ + $(O_FILES) $(CMA_FILES) $(CMO_FILES) $(ADD_CMO_FILES) \ + in/blah.ml + @$(OCAMLC) $(ADD_COMPFLAGS) $(ADD_CFLAGS) -o out/foo.cmo -c \ + $(O_FILES) $(CMA_FILES) $(CMO_FILES) $(ADD_CMO_FILES) \ + -I out in/foo.ml + @$(OCAMLC) $(ADD_COMPFLAGS) $(ADD_CFLAGS) -o program.byte$(EXE) \ + $(O_FILES) $(CMA_FILES) $(CMO_FILES) $(ADD_CMO_FILES) \ + out/blah.cmo out/foo.cmo + @mkdir -p compiler-libs + @cp $(TOPDIR)/toplevel/topdirs.cmi compiler-libs/ + +.PHONY: run +run: + @printf " ... testing with ocamlc" + @rm -f $(MAIN_MODULE).result + @echo 'source input_script' | \ + $(OCAMLRUN) `$(CYGPATH) $(TOPDIR)/debugger/ocamldebug$(EXE)` \ + program.byte$(EXE) >$(MAIN_MODULE).raw.result 2>&1 \ + && sed -e '/Debugger version/d' -e '/^Time:/d' \ + -e '/Breakpoint [0-9]* at [0-9]*:/d' -e '$$d' \ + $(MAIN_MODULE).raw.result >$(MAIN_MODULE).result \ + && $(DIFF) $(MAIN_MODULE).reference $(MAIN_MODULE).result >/dev/null \ + && echo " => passed" || echo " => failed" + +.PHONY: promote +promote: defaultpromote + +.PHONY: clean +clean: defaultclean + @rm -f *.result program.byte program.byte.exe \ + program.native program.native.exe \ + $(GENERATED_SOURCES) $(O_FILES) $(TEST_TEMP_FILES) + @rm -rf compiler-libs out + +include $(BASEDIR)/makefiles/Makefile.common diff --git a/testsuite/tests/tool-debugger/find-artifacts/debuggee.reference b/testsuite/tests/tool-debugger/find-artifacts/debuggee.reference new file mode 100644 index 0000000000..06564f90bb --- /dev/null +++ b/testsuite/tests/tool-debugger/find-artifacts/debuggee.reference @@ -0,0 +1,6 @@ + +(ocd) Loading program... done. +Breakpoint: 1 +10 <|b|>print x; +x: Blah.blah = Foo +y: Blah.blah = Bar "hi" diff --git a/testsuite/tests/tool-debugger/find-artifacts/in/blah.ml b/testsuite/tests/tool-debugger/find-artifacts/in/blah.ml new file mode 100644 index 0000000000..462c07b2e1 --- /dev/null +++ b/testsuite/tests/tool-debugger/find-artifacts/in/blah.ml @@ -0,0 +1,3 @@ +type blah = + | Foo + | Bar of string diff --git a/testsuite/tests/tool-debugger/find-artifacts/in/foo.ml b/testsuite/tests/tool-debugger/find-artifacts/in/foo.ml new file mode 100644 index 0000000000..8d992673be --- /dev/null +++ b/testsuite/tests/tool-debugger/find-artifacts/in/foo.ml @@ -0,0 +1,13 @@ +open Blah + +let print = function + | Foo -> print_endline "Foo"; + | Bar s -> print_endline ("Bar(" ^ s ^ ")") + +let main () = + let x = Foo in + let y = Bar "hi" in + print x; + print y + +let _ = main () diff --git a/testsuite/tests/tool-debugger/find-artifacts/input_script b/testsuite/tests/tool-debugger/find-artifacts/input_script new file mode 100644 index 0000000000..4b907c5ae6 --- /dev/null +++ b/testsuite/tests/tool-debugger/find-artifacts/input_script @@ -0,0 +1,5 @@ +break @ Foo 10 +run +print x +print y +quit diff --git a/testsuite/tests/tool-lexyacc/lexgen.ml b/testsuite/tests/tool-lexyacc/lexgen.ml index d5dd517a5b..005ea68d9b 100644 --- a/testsuite/tests/tool-lexyacc/lexgen.ml +++ b/testsuite/tests/tool-lexyacc/lexgen.ml @@ -166,7 +166,7 @@ let rec lastpos = function let followpos size name_regexp_list = - let v = Array.create size [] in + let v = Array.make size [] in let fill_pos first = function OnChars pos -> v.(pos) <- merge_trans first v.(pos); () | ToAction _ -> () in @@ -223,8 +223,8 @@ let goto_state = function let transition_from chars follow pos_set = - let tr = Array.create 256 [] - and shift = Array.create 256 Backtrack in + let tr = Array.make 256 [] + and shift = Array.make 256 Backtrack in List.iter (fun pos -> List.iter @@ -263,6 +263,6 @@ let make_dfa lexdef = let states = map_on_states (translate_state chars follow) in let v = - Array.create (number_of_states()) (Perform 0) in + Array.make (number_of_states()) (Perform 0) in List.iter (fun (auto, i) -> v.(i) <- auto) states; (initial_states, v, actions) diff --git a/testsuite/tests/tool-toplevel/Makefile b/testsuite/tests/tool-toplevel/Makefile new file mode 100644 index 0000000000..c9433b2ecb --- /dev/null +++ b/testsuite/tests/tool-toplevel/Makefile @@ -0,0 +1,15 @@ +######################################################################### +# # +# OCaml # +# # +# Xavier Clerc, SED, INRIA Rocquencourt # +# # +# Copyright 2010 Institut National de Recherche en Informatique et # +# en Automatique. All rights reserved. This file is distributed # +# under the terms of the Q Public License version 1.0. # +# # +######################################################################### + +BASEDIR=../.. +include $(BASEDIR)/makefiles/Makefile.toplevel +include $(BASEDIR)/makefiles/Makefile.common diff --git a/testsuite/tests/tool-toplevel/tracing.ml b/testsuite/tests/tool-toplevel/tracing.ml new file mode 100644 index 0000000000..5acaff238c --- /dev/null +++ b/testsuite/tests/tool-toplevel/tracing.ml @@ -0,0 +1,4 @@ +List.fold_left;; +#trace List.fold_left;; +0;; +List.fold_left (+) 0 [1;2;3];; diff --git a/testsuite/tests/tool-toplevel/tracing.ml.reference b/testsuite/tests/tool-toplevel/tracing.ml.reference new file mode 100644 index 0000000000..e6eda8d7f9 --- /dev/null +++ b/testsuite/tests/tool-toplevel/tracing.ml.reference @@ -0,0 +1,30 @@ + +# - : ('a -> 'b -> 'a) -> 'a -> 'b list -> 'a = <fun> +# List.fold_left is now traced. +# - : int = 0 +# List.fold_left <-- <fun> +List.fold_left --> <fun> +List.fold_left* <-- <poly> +List.fold_left* --> <fun> +List.fold_left** <-- [<poly>; <poly>; <poly>] +List.fold_left <-- <fun> +List.fold_left --> <fun> +List.fold_left* <-- <poly> +List.fold_left* --> <fun> +List.fold_left** <-- [<poly>; <poly>] +List.fold_left <-- <fun> +List.fold_left --> <fun> +List.fold_left* <-- <poly> +List.fold_left* --> <fun> +List.fold_left** <-- [<poly>] +List.fold_left <-- <fun> +List.fold_left --> <fun> +List.fold_left* <-- <poly> +List.fold_left* --> <fun> +List.fold_left** <-- [] +List.fold_left** --> <poly> +List.fold_left** --> <poly> +List.fold_left** --> <poly> +List.fold_left** --> <poly> +- : int = 6 +# diff --git a/testsuite/tests/typing-gadts/didier.ml b/testsuite/tests/typing-gadts/didier.ml new file mode 100644 index 0000000000..8091375c0a --- /dev/null +++ b/testsuite/tests/typing-gadts/didier.ml @@ -0,0 +1,48 @@ +type 'a ty = + | Int : int ty + | Bool : bool ty + +let fbool (type t) (x : t) (tag : t ty) = + match tag with + | Bool -> x +;; +(* val fbool : 'a -> 'a ty -> 'a = <fun> *) +(** OK: the return value is x of type t **) + +let fint (type t) (x : t) (tag : t ty) = + match tag with + | Int -> x > 0 +;; +(* val fint : 'a -> 'a ty -> bool = <fun> *) +(** OK: the return value is x > 0 of type bool; +This has used the equation t = bool, not visible in the return type **) + +let f (type t) (x : t) (tag : t ty) = + match tag with + | Int -> x > 0 + | Bool -> x +(* val f : 'a -> 'a ty -> bool = <fun> *) + + +let g (type t) (x : t) (tag : t ty) = + match tag with + | Bool -> x + | Int -> x > 0 +(* Error: This expression has type bool but an expression was expected of type +t = int *) + +let id x = x;; +let idb1 = (fun id -> let _ = id true in id) id;; +let idb2 : bool -> bool = id;; +let idb3 ( _ : bool ) = false;; + +let g (type t) (x : t) (tag : t ty) = + match tag with + | Bool -> idb3 x + | Int -> x > 0 + +let g (type t) (x : t) (tag : t ty) = + match tag with + | Bool -> idb2 x + | Int -> x > 0 + diff --git a/testsuite/tests/typing-misc/constraints.ml b/testsuite/tests/typing-misc/constraints.ml index 5408ca2c1b..a006363254 100644 --- a/testsuite/tests/typing-misc/constraints.ml +++ b/testsuite/tests/typing-misc/constraints.ml @@ -14,3 +14,11 @@ type 'a t = 'a;; let f (x : 'a t as 'a) = ();; (* fails *) let f (x : 'a t) (y : 'a) = x = y;; + +(* PR#6505 *) +module type PR6505 = sig + type 'o is_an_object = < .. > as 'o + and 'o abs constraint 'o = 'o is_an_object + val abs : 'o is_an_object -> 'o abs + val unabs : 'o abs -> 'o +end;; (* fails *) diff --git a/testsuite/tests/typing-misc/constraints.ml.reference b/testsuite/tests/typing-misc/constraints.ml.reference index fe52044002..83a3dc1f99 100644 --- a/testsuite/tests/typing-misc/constraints.ml.reference +++ b/testsuite/tests/typing-misc/constraints.ml.reference @@ -26,4 +26,9 @@ Error: This alias is bound to type 'a t = 'a but is used as an instance of type 'a The type variable 'a occurs inside 'a # val f : 'a t -> 'a -> bool = <fun> +# Characters 83-122: + and 'o abs constraint 'o = 'o is_an_object + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: The definition of abs contains a cycle: + 'a is_an_object as 'a # diff --git a/testsuite/tests/typing-misc/labels.ml.principal.reference b/testsuite/tests/typing-misc/labels.ml.principal.reference index 2f21fd3f0b..f8be126bb8 100644 --- a/testsuite/tests/typing-misc/labels.ml.principal.reference +++ b/testsuite/tests/typing-misc/labels.ml.principal.reference @@ -12,5 +12,5 @@ Warning 43: the label x is not optional. foo (fun ?opt () -> ()) ;; (* fails *) ^^^^^^^^^^^^^^^^^^^ Error: This function should have type unit -> unit - but its first argument is labelled ~?opt + but its first argument is labelled ?opt # diff --git a/testsuite/tests/typing-misc/labels.ml.reference b/testsuite/tests/typing-misc/labels.ml.reference index 2f21fd3f0b..f8be126bb8 100644 --- a/testsuite/tests/typing-misc/labels.ml.reference +++ b/testsuite/tests/typing-misc/labels.ml.reference @@ -12,5 +12,5 @@ Warning 43: the label x is not optional. foo (fun ?opt () -> ()) ;; (* fails *) ^^^^^^^^^^^^^^^^^^^ Error: This function should have type unit -> unit - but its first argument is labelled ~?opt + but its first argument is labelled ?opt # diff --git a/testsuite/tests/typing-misc/variant.ml b/testsuite/tests/typing-misc/variant.ml new file mode 100644 index 0000000000..b0bd522277 --- /dev/null +++ b/testsuite/tests/typing-misc/variant.ml @@ -0,0 +1,8 @@ +(* PR#6394 *) + +module rec X : sig + type t = int * bool +end = struct + type t = A | B + let f = function A | B -> 0 +end;; diff --git a/testsuite/tests/typing-misc/variant.ml.reference b/testsuite/tests/typing-misc/variant.ml.reference new file mode 100644 index 0000000000..4de6b611e6 --- /dev/null +++ b/testsuite/tests/typing-misc/variant.ml.reference @@ -0,0 +1,16 @@ + +# Characters 61-116: + ......struct + type t = A | B + let f = function A | B -> 0 + end.. +Error: Signature mismatch: + Modules do not match: + sig type t = X.t = A | B val f : t -> int end + is not included in + sig type t = int * bool end + Type declarations do not match: + type t = X.t = A | B + is not included in + type t = int * bool +# diff --git a/testsuite/tests/typing-modules-bugs/pr6427_bad.ml b/testsuite/tests/typing-modules-bugs/pr6427_bad.ml new file mode 100644 index 0000000000..286dafb88a --- /dev/null +++ b/testsuite/tests/typing-modules-bugs/pr6427_bad.ml @@ -0,0 +1,20 @@ +let flag = ref false +module F(S : sig module type T end) (A : S.T) (B : S.T) = +struct + module X = (val if !flag then (module A) else (module B) : S.T) +end + +(* If the above were accepted, one could break soundness *) +module type S = sig type t val x : t end +module Float = struct type t = float let x = 0.0 end +module Int = struct type t = int let x = 0 end + +module M = F(struct module type T = S end) + +let () = flag := false +module M1 = M(Float)(Int) + +let () = flag := true +module M2 = M(Float)(Int) + +let _ = [| M2.X.x; M1.X.x |] diff --git a/testsuite/tests/typing-modules-bugs/pr6513_ok.ml b/testsuite/tests/typing-modules-bugs/pr6513_ok.ml new file mode 100644 index 0000000000..f23fc599af --- /dev/null +++ b/testsuite/tests/typing-modules-bugs/pr6513_ok.ml @@ -0,0 +1,25 @@ +module type PR6513 = sig +module type S = sig type u end + +module type T = sig + type 'a wrap + type uri +end + +module Make: functor (Html5 : T with type 'a wrap = 'a) -> + S with type u = < foo : Html5.uri > +end + +(* Requires -package tyxml +module type PR6513_orig = sig +module type S = +sig + type t + type u +end + +module Make: functor (Html5: Html5_sigs.T with type 'a Xml.wrap = 'a and type 'a wrap = 'a and type 'a list_wrap = 'a list) -> S with + type t = Html5_types.div Html5.elt and + type u = < foo: Html5.uri > +end +*) diff --git a/testsuite/tests/typing-modules/aliases.ml b/testsuite/tests/typing-modules/aliases.ml index b77b0c47db..3eca527145 100644 --- a/testsuite/tests/typing-modules/aliases.ml +++ b/testsuite/tests/typing-modules/aliases.ml @@ -4,11 +4,6 @@ C.chr 66;; module C' : module type of Char = C;; C'.chr 66;; -module C'' : (module C) = C';; (* fails *) - -module C'' : (module Char) = C;; -C''.chr 66;; - module C3 = struct include Char end;; C3.chr 66;; @@ -220,3 +215,23 @@ module K = struct end;; let x : K.N.t = "foo";; + +(* PR#6465 *) + +module M = struct type t = A module B = struct type u = B end end;; +module P : sig type t = M.t = A module B = M.B end = M;; (* should be ok *) +module P : sig type t = M.t = A module B = M.B end = struct include M end;; + +module type S = sig + module M : sig module P : sig end end + module Q = M +end;; +module type S = sig + module M : sig module N : sig end module P : sig end end + module Q : sig module N = M.N module P = M.P end +end;; +module R = struct + module M = struct module N = struct end module P = struct end end + module Q = M +end;; +module R' : S = R;; (* should be ok *) diff --git a/testsuite/tests/typing-modules/aliases.ml.reference b/testsuite/tests/typing-modules/aliases.ml.reference index e820b78e28..2bb3231de4 100644 --- a/testsuite/tests/typing-modules/aliases.ml.reference +++ b/testsuite/tests/typing-modules/aliases.ml.reference @@ -13,13 +13,6 @@ external unsafe_chr : int -> char = "%identity" end # - : char = 'B' -# Characters 27-29: - module C'' : (module C) = C';; (* fails *) - ^^ -Error: Signature mismatch: - Modules do not match: (module C') is not included in (module C) -# module C'' = Char -# - : char = 'B' # module C3 : sig external code : char -> int = "%identity" @@ -374,4 +367,48 @@ Error: Unbound module type A # module B : sig module R : sig type t = string end module O = R end module K : sig module E = B module N = E.O end # val x : K.N.t = "foo" +# module M : sig type t = A module B : sig type u = B end end +# Characters 53-54: + module P : sig type t = M.t = A module B = M.B end = M;; (* should be ok *) + ^ +Error: Signature mismatch: + Modules do not match: + sig type t = M.t = A module B : sig type u = M.B.u = B end end + is not included in + sig type t = M.t = A module B = M.B end + In module B: + Modules do not match: + sig type u = M.B.u = B end + is not included in + (module M.B) +# module P : sig type t = M.t = A module B = M.B end +# module type S = sig module M : sig module P : sig end end module Q = M end +# module type S = + sig + module M : sig module N : sig end module P : sig end end + module Q : sig module N = M.N module P = M.P end + end +# module R : + sig + module M : sig module N : sig end module P : sig end end + module Q = M + end +# Characters 16-17: + module R' : S = R;; (* should be ok *) + ^ +Error: Signature mismatch: + Modules do not match: + sig + module M : sig module N : sig end module P : sig end end + module Q = M + end + is not included in + S + In module Q: + Modules do not match: + sig module N : sig end module P : sig end end + is not included in + sig module N = M.N module P = M.P end + In module Q.N: + Modules do not match: sig end is not included in (module M.N) # diff --git a/testsuite/tests/typing-objects/Exemples.ml b/testsuite/tests/typing-objects/Exemples.ml index ba3e64f011..5ffc6498f9 100644 --- a/testsuite/tests/typing-objects/Exemples.ml +++ b/testsuite/tests/typing-objects/Exemples.ml @@ -170,14 +170,14 @@ p1#print (fun x -> x#print);; (*******************************************************************) class virtual comparable () = object (self : 'a) - method virtual leq : 'a -> bool + method virtual cmp : 'a -> int end;; class int_comparable (x : int) = object inherit comparable () val x = x method x = x - method leq p = x <= p#x + method cmp p = compare x p#x end;; class int_comparable2 xi = object @@ -193,7 +193,7 @@ class ['a] sorted_list () = object let rec insert = function [] -> [x] - | a::l as l' -> if a#leq x then a::(insert l) else x::l' + | a::l as l' -> if a#cmp x <= 0 then a::(insert l) else x::l' in l <- insert l method hd = List.hd l @@ -209,7 +209,7 @@ l#add (c2 :> int_comparable);; (* Echec : 'a comp2 n'est un sous-type *) class int_comparable3 (x : int) = object val mutable x = x - method leq (y : int_comparable) = x < y#x + method cmp (y : int_comparable) = compare x y#x method x = x method setx y = x <- y end;; @@ -218,7 +218,7 @@ let c3 = new int_comparable3 15;; l#add (c3 :> int_comparable);; (new sorted_list ())#add c3;; (* Error; strange message with -principal *) -let sort (l : #comparable list) = Sort.list (fun x -> x#leq) l;; +let sort (l : #comparable list) = List.sort (fun x -> x#cmp) l;; let pr l = List.map (fun c -> print_int c#x; print_string " ") l; print_newline ();; @@ -231,7 +231,7 @@ pr l;; pr (sort l);; let min (x : #comparable) y = - if x#leq y then x else y;; + if x#cmp y <= 0 then x else y;; (min (new int_comparable 7) (new int_comparable 11))#x;; (min (new int_comparable2 5) (new int_comparable2 3))#x;; diff --git a/testsuite/tests/typing-objects/Exemples.ml.principal.reference b/testsuite/tests/typing-objects/Exemples.ml.principal.reference index 0b04607a21..2b12a7d9b7 100644 --- a/testsuite/tests/typing-objects/Exemples.ml.principal.reference +++ b/testsuite/tests/typing-objects/Exemples.ml.principal.reference @@ -183,15 +183,15 @@ and ['a] cons : # val p1 : printable_color_point lst = <obj> # ((3, red)::(10, red)::[])- : unit = () # class virtual comparable : - unit -> object ('a) method virtual leq : 'a -> bool end + unit -> object ('a) method virtual cmp : 'a -> int end # class int_comparable : - int -> object ('a) val x : int method leq : 'a -> bool method x : int end + int -> object ('a) val x : int method cmp : 'a -> int method x : int end # class int_comparable2 : int -> object ('a) val x : int val mutable x' : int - method leq : 'a -> bool + method cmp : 'a -> int method set_x : int -> unit method x : int end @@ -212,19 +212,19 @@ and ['a] cons : ^^^^^^^^^^^^^^^^^^^^^^ Error: Type int_comparable2 = - < leq : int_comparable2 -> bool; set_x : int -> unit; x : int > + < cmp : int_comparable2 -> int; set_x : int -> unit; x : int > is not a subtype of - int_comparable = < leq : int_comparable -> bool; x : int > - Type int_comparable = < leq : int_comparable -> bool; x : int > + int_comparable = < cmp : int_comparable -> int; x : int > + Type int_comparable = < cmp : int_comparable -> int; x : int > is not a subtype of int_comparable2 = - < leq : int_comparable2 -> bool; set_x : int -> unit; x : int > + < cmp : int_comparable2 -> int; set_x : int -> unit; x : int > # - : unit = () # class int_comparable3 : int -> object val mutable x : int - method leq : int_comparable -> bool + method cmp : int_comparable -> int method setx : int -> unit method x : int end @@ -235,11 +235,11 @@ Error: Type ^^ Error: This expression has type int_comparable3 = - < leq : int_comparable -> bool; setx : int -> unit; x : int > + < cmp : int_comparable -> int; setx : int -> unit; x : int > but an expression was expected of type - #comparable as 'a = < leq : 'a -> bool; .. > - Type int_comparable = < leq : int_comparable -> bool; x : int > - is not compatible with type 'a = < leq : 'a -> bool; .. > + #comparable as 'a = < cmp : 'a -> int; .. > + Type int_comparable = < cmp : int_comparable -> int; x : int > + is not compatible with type 'a = < cmp : 'a -> int; .. > The first object type has no method setx # val sort : (#comparable as 'a) list -> 'a list = <fun> # Characters 13-66: diff --git a/testsuite/tests/typing-objects/Exemples.ml.reference b/testsuite/tests/typing-objects/Exemples.ml.reference index 353f607cb5..7cbd68ec29 100644 --- a/testsuite/tests/typing-objects/Exemples.ml.reference +++ b/testsuite/tests/typing-objects/Exemples.ml.reference @@ -183,15 +183,15 @@ and ['a] cons : # val p1 : printable_color_point lst = <obj> # ((3, red)::(10, red)::[])- : unit = () # class virtual comparable : - unit -> object ('a) method virtual leq : 'a -> bool end + unit -> object ('a) method virtual cmp : 'a -> int end # class int_comparable : - int -> object ('a) val x : int method leq : 'a -> bool method x : int end + int -> object ('a) val x : int method cmp : 'a -> int method x : int end # class int_comparable2 : int -> object ('a) val x : int val mutable x' : int - method leq : 'a -> bool + method cmp : 'a -> int method set_x : int -> unit method x : int end @@ -212,19 +212,19 @@ and ['a] cons : ^^^^^^^^^^^^^^^^^^^^^^ Error: Type int_comparable2 = - < leq : int_comparable2 -> bool; set_x : int -> unit; x : int > + < cmp : int_comparable2 -> int; set_x : int -> unit; x : int > is not a subtype of - int_comparable = < leq : int_comparable -> bool; x : int > - Type int_comparable = < leq : int_comparable -> bool; x : int > + int_comparable = < cmp : int_comparable -> int; x : int > + Type int_comparable = < cmp : int_comparable -> int; x : int > is not a subtype of int_comparable2 = - < leq : int_comparable2 -> bool; set_x : int -> unit; x : int > + < cmp : int_comparable2 -> int; set_x : int -> unit; x : int > # - : unit = () # class int_comparable3 : int -> object val mutable x : int - method leq : int_comparable -> bool + method cmp : int_comparable -> int method setx : int -> unit method x : int end @@ -235,13 +235,13 @@ Error: Type ^^ Error: This expression has type int_comparable3 = - < leq : int_comparable -> bool; setx : int -> unit; x : int > + < cmp : int_comparable -> int; setx : int -> unit; x : int > but an expression was expected of type - #comparable as 'a = < leq : 'a -> bool; .. > - Type int_comparable = < leq : int_comparable -> bool; x : int > + #comparable as 'a = < cmp : 'a -> int; .. > + Type int_comparable = < cmp : int_comparable -> int; x : int > is not compatible with type int_comparable3 = - < leq : int_comparable -> bool; setx : int -> unit; x : int > + < cmp : int_comparable -> int; setx : int -> unit; x : int > The first object type has no method setx # val sort : (#comparable as 'a) list -> 'a list = <fun> # Characters 13-66: diff --git a/testsuite/tests/typing-objects/Tests.ml b/testsuite/tests/typing-objects/Tests.ml index befd70d948..917474f961 100644 --- a/testsuite/tests/typing-objects/Tests.ml +++ b/testsuite/tests/typing-objects/Tests.ml @@ -236,7 +236,7 @@ end;; let d = new d () in d#xc, d#xd;; class virtual ['a] matrix (sz, init : int * 'a) = object - val m = Array.create_matrix sz sz init + val m = Array.make_matrix sz sz init method add (mtx : 'a matrix) = (mtx#m.(0).(0) : 'a) end;; @@ -305,26 +305,28 @@ class c () = object method virtual m : int method private m = 1 end;; (* Marshaling (cf. PR#5436) *) -Oo.id (object end);; -Oo.id (object end);; -Oo.id (object end);; +let r = ref 0;; +let id o = Oo.id o - !r;; +r := Oo.id (object end);; +id (object end);; +id (object end);; let o = object end in let s = Marshal.to_string o [] in let o' : < > = Marshal.from_string s 0 in let o'' : < > = Marshal.from_string s 0 in - (Oo.id o, Oo.id o', Oo.id o'');; + (id o, id o', id o'');; let o = object val x = 33 method m = x end in let s = Marshal.to_string o [Marshal.Closures] in let o' : <m:int> = Marshal.from_string s 0 in let o'' : <m:int> = Marshal.from_string s 0 in - (Oo.id o, Oo.id o', Oo.id o'', o#m, o'#m);; + (id o, id o', id o'', o#m, o'#m);; let o = object val x = 33 val y = 44 method m = x end in - let s = Marshal.to_string o [Marshal.Closures] in - let o' : <m:int> = Marshal.from_string s 0 in - let o'' : <m:int> = Marshal.from_string s 0 in - (Oo.id o, Oo.id o', Oo.id o'', o#m, o'#m);; + let s = Marshal.to_string (o,o) [Marshal.Closures] in + let (o1, o2) : (<m:int> * <m:int>) = Marshal.from_string s 0 in + let (o3, o4) : (<m:int> * <m:int>) = Marshal.from_string s 0 in + (id o, id o1, id o2, id o3, id o4, o#m, o1#m);; (* Recursion (cf. PR#5291) *) diff --git a/testsuite/tests/typing-objects/Tests.ml.principal.reference b/testsuite/tests/typing-objects/Tests.ml.principal.reference index 4821b58781..e5d9bb8d59 100644 --- a/testsuite/tests/typing-objects/Tests.ml.principal.reference +++ b/testsuite/tests/typing-objects/Tests.ml.principal.reference @@ -217,9 +217,9 @@ class e : # * * * * * * * * * * * * * * * * * * * * * module M : sig class c : unit -> object method xc : int end end # class d : unit -> object val x : int method xc : int method xd : int end # - : int * int = (1, 2) -# Characters 7-156: +# Characters 7-154: ......virtual ['a] matrix (sz, init : int * 'a) = object - val m = Array.create_matrix sz sz init + val m = Array.make_matrix sz sz init method add (mtx : 'a matrix) = (mtx#m.(0).(0) : 'a) end.. Error: The abbreviation 'a matrix expands to type < add : 'a matrix -> 'a > @@ -295,12 +295,14 @@ Warning 10: this expression should have type unit. unit -> object method private m : int method n : int method o : int end # - : int * int = (1, 1) # class c : unit -> object method m : int end -# - : int = 100 -# - : int = 101 -# - : int = 102 -# - : int * int * int = (103, 104, 105) -# - : int * int * int * int * int = (106, 107, 108, 33, 33) -# - : int * int * int * int * int = (109, 110, 111, 33, 33) +# val r : int ref = {contents = 0} +# val id : < .. > -> int = <fun> +# - : unit = () +# - : int = 1 +# - : int = 2 +# - : int * int * int = (3, 4, 5) +# - : int * int * int * int * int = (6, 7, 8, 33, 33) +# - : int * int * int * int * int * int * int = (9, 10, 10, 11, 11, 33, 33) # Characters 42-69: class a = let _ = new b in object end ^^^^^^^^^^^^^^^^^^^^^^^^^^^ diff --git a/testsuite/tests/typing-objects/Tests.ml.reference b/testsuite/tests/typing-objects/Tests.ml.reference index 25ab6d86c6..ed4df922d4 100644 --- a/testsuite/tests/typing-objects/Tests.ml.reference +++ b/testsuite/tests/typing-objects/Tests.ml.reference @@ -217,9 +217,9 @@ class e : # * * * * * * * * * * * * * * * * * * * * * module M : sig class c : unit -> object method xc : int end end # class d : unit -> object val x : int method xc : int method xd : int end # - : int * int = (1, 2) -# Characters 7-156: +# Characters 7-154: ......virtual ['a] matrix (sz, init : int * 'a) = object - val m = Array.create_matrix sz sz init + val m = Array.make_matrix sz sz init method add (mtx : 'a matrix) = (mtx#m.(0).(0) : 'a) end.. Error: The abbreviation 'a matrix expands to type < add : 'a matrix -> 'a > @@ -294,12 +294,14 @@ Warning 10: this expression should have type unit. unit -> object method private m : int method n : int method o : int end # - : int * int = (1, 1) # class c : unit -> object method m : int end -# - : int = 100 -# - : int = 101 -# - : int = 102 -# - : int * int * int = (103, 104, 105) -# - : int * int * int * int * int = (106, 107, 108, 33, 33) -# - : int * int * int * int * int = (109, 110, 111, 33, 33) +# val r : int ref = {contents = 0} +# val id : < .. > -> int = <fun> +# - : unit = () +# - : int = 1 +# - : int = 2 +# - : int * int * int = (3, 4, 5) +# - : int * int * int * int * int = (6, 7, 8, 33, 33) +# - : int * int * int * int * int * int * int = (9, 10, 10, 11, 11, 33, 33) # Characters 42-69: class a = let _ = new b in object end ^^^^^^^^^^^^^^^^^^^^^^^^^^^ diff --git a/testsuite/tests/typing-private/private.ml.principal.reference b/testsuite/tests/typing-private/private.ml.principal.reference index 03e7957016..96b1d75955 100644 --- a/testsuite/tests/typing-private/private.ml.principal.reference +++ b/testsuite/tests/typing-private/private.ml.principal.reference @@ -107,7 +107,7 @@ Error: Cannot create values of the private type Test2.t # * Characters 148-171: module Test2 : module type of Test with type t = private Test.t = Test;; ^^^^^^^^^^^^^^^^^^^^^^^ -Warning 3: deprecated feature: spurious use of private +Warning 3: deprecated: spurious use of private module Test2 : sig type t = Test.t = private A end # type t = private < x : int; .. > # type t = private < x : int; .. > diff --git a/testsuite/tests/typing-private/private.ml.reference b/testsuite/tests/typing-private/private.ml.reference index 360940c927..cb1573ed49 100644 --- a/testsuite/tests/typing-private/private.ml.reference +++ b/testsuite/tests/typing-private/private.ml.reference @@ -107,7 +107,7 @@ Error: Cannot create values of the private type Test2.t # * Characters 148-171: module Test2 : module type of Test with type t = private Test.t = Test;; ^^^^^^^^^^^^^^^^^^^^^^^ -Warning 3: deprecated feature: spurious use of private +Warning 3: deprecated: spurious use of private module Test2 : sig type t = Test.t = private A end # type t = private < x : int; .. > # type t = private < x : int; .. > diff --git a/tools/.depend b/tools/.depend index ea66ede860..b0407009d2 100644 --- a/tools/.depend +++ b/tools/.depend @@ -40,11 +40,13 @@ eqparsetree.cmo : ../parsing/parsetree.cmi ../parsing/longident.cmi \ eqparsetree.cmx : ../parsing/parsetree.cmi ../parsing/longident.cmx \ ../parsing/location.cmx ../parsing/asttypes.cmi objinfo.cmo : ../asmcomp/printclambda.cmi ../utils/misc.cmi \ - ../utils/config.cmi ../asmcomp/cmx_format.cmi ../bytecomp/cmo_format.cmi \ - ../typing/cmi_format.cmi ../bytecomp/bytesections.cmi + ../utils/config.cmi ../asmcomp/cmx_format.cmi ../typing/cmt_format.cmi \ + ../bytecomp/cmo_format.cmi ../typing/cmi_format.cmi \ + ../bytecomp/bytesections.cmi objinfo.cmx : ../asmcomp/printclambda.cmx ../utils/misc.cmx \ - ../utils/config.cmx ../asmcomp/cmx_format.cmi ../bytecomp/cmo_format.cmi \ - ../typing/cmi_format.cmx ../bytecomp/bytesections.cmx + ../utils/config.cmx ../asmcomp/cmx_format.cmi ../typing/cmt_format.cmx \ + ../bytecomp/cmo_format.cmi ../typing/cmi_format.cmx \ + ../bytecomp/bytesections.cmx ocaml299to3.cmo : ocaml299to3.cmx : ocamlcp.cmo : ../driver/main_args.cmi diff --git a/tools/check-typo b/tools/check-typo index ea7c63f775..bd48dc7a3e 100755 --- a/tools/check-typo +++ b/tools/check-typo @@ -39,11 +39,11 @@ # automatically exempt from all rules # *.reference # */reference +# */.depend* # - Any file whose name begins with "Makefile" is automatically exempt # from the "tabs" rule. # - Any file whose name matches one of the following patterns is # automatically exempt from the "missing-header" rule. -# */.depend* # */.ignore # *.mlpack # *.mllib @@ -137,9 +137,9 @@ IGNORE_DIRS=" add_hd(){ rules="missing-header,$rules"; } case "$f" in Makefile*|*/Makefile*) rules="tab,$rules";; - */.depend*|*/.ignore) add_hd;; + */.ignore) add_hd;; *.mlpack|*.mllib|*.mltop|*.odocl|*.itarget|*.clib) add_hd;; - *.reference|*/reference) continue;; + *.reference|*/reference|*/.depend*) continue;; esac case "$f" in ocamldoc/*|*/ocamldoc/*) rules="long-line,$rules";; diff --git a/tools/cmt2annot.ml b/tools/cmt2annot.ml index eee0c79065..36ca187ca5 100644 --- a/tools/cmt2annot.ml +++ b/tools/cmt2annot.ml @@ -179,9 +179,13 @@ let gen_ml target_filename filename cmt = let (printer, ext) = match cmt.Cmt_format.cmt_annots with | Cmt_format.Implementation typedtree -> - (fun ppf -> Pprintast.structure ppf (Untypeast.untype_structure typedtree)), ".ml" + (fun ppf -> Pprintast.structure ppf + (Untypeast.untype_structure typedtree)), + ".ml" | Cmt_format.Interface typedtree -> - (fun ppf -> Pprintast.signature ppf (Untypeast.untype_signature typedtree)), ".mli" + (fun ppf -> Pprintast.signature ppf + (Untypeast.untype_signature typedtree)), + ".mli" | _ -> Printf.fprintf stderr "File was generated with an error\n%!"; exit 2 diff --git a/tools/dumpobj.ml b/tools/dumpobj.ml index d95c210da4..f1e2897381 100644 --- a/tools/dumpobj.ml +++ b/tools/dumpobj.ml @@ -519,7 +519,7 @@ let dump_exe ic = primitives := read_primitive_table ic prim_size; ignore(Bytesections.seek_section ic "DATA"); let init_data = (input_value ic : Obj.t array) in - globals := Array.create (Array.length init_data) Empty; + globals := Array.make (Array.length init_data) Empty; for i = 0 to Array.length init_data - 1 do !globals.(i) <- Constant (init_data.(i)) done; diff --git a/tools/make-package-macosx b/tools/make-package-macosx index 1fa08919d2..e823156ba0 100755 --- a/tools/make-package-macosx +++ b/tools/make-package-macosx @@ -85,7 +85,7 @@ mkdir -p resources cat >resources/ReadMe.txt <<EOF This package installs OCaml version ${VERSION}. You need Mac OS X 10.7.x (Lion) or later, with the -XCode tools installed (v4.3.3 or later). +XCode tools installed (v4.6.3 or later). Files will be installed in the following directories: diff --git a/tools/objinfo_helper.c b/tools/objinfo_helper.c index 58dfd2d459..a8c79bd39d 100644 --- a/tools/objinfo_helper.c +++ b/tools/objinfo_helper.c @@ -17,7 +17,12 @@ #ifdef HAS_LIBBFD #include <stdlib.h> #include <string.h> + +// PACKAGE: protect against binutils change +// https://sourceware.org/bugzilla/show_bug.cgi?id=14243 +#define PACKAGE "ocamlobjinfo" #include <bfd.h> +#undef PACKAGE int main(int argc, char ** argv) { diff --git a/tools/ocamlcp.ml b/tools/ocamlcp.ml index 75adcb82ef..51559aea3e 100644 --- a/tools/ocamlcp.ml +++ b/tools/ocamlcp.ml @@ -83,6 +83,7 @@ module Options = Main_args.Make_bytecomp_options (struct let _safe_string = option "-safe-string" let _short_paths = option "-short-paths" let _strict_sequence = option "-strict-sequence" + let _strict_formats = option "-strict-formats" let _thread () = option "-thread" () let _vmthread () = option "-vmthread" () let _unsafe = option "-unsafe" diff --git a/tools/ocamloptp.ml b/tools/ocamloptp.ml index 178f7c2d25..0b788843fe 100644 --- a/tools/ocamloptp.ml +++ b/tools/ocamloptp.ml @@ -86,6 +86,7 @@ module Options = Main_args.Make_optcomp_options (struct let _safe_string = option "-safe-string" let _short_paths = option "-short-paths" let _strict_sequence = option "-strict-sequence" + let _strict_formats = option "-strict-formats" let _shared = option "-shared" let _thread = option "-thread" let _unsafe = option "-unsafe" @@ -120,6 +121,7 @@ module Options = Main_args.Make_optcomp_options (struct let _dscheduling = option "-dscheduling" let _dlinear = option "-dlinear" let _dstartup = option "-dstartup" + let _opaque = option "-opaque" let anonymous = process_file end);; diff --git a/tools/ocamlprof.ml b/tools/ocamlprof.ml index 9c2bb489dd..dde248cd48 100644 --- a/tools/ocamlprof.ml +++ b/tools/ocamlprof.ml @@ -86,7 +86,7 @@ let add_incr_counter modul (kind,pos) = | Close -> fprintf !outchan ")"; ;; -let counters = ref (Array.create 0 0) +let counters = ref (Array.make 0 0) (* User defined marker *) let special_id = ref "" @@ -122,7 +122,7 @@ let init_rewrite modes mod_name = cur_point := 0; if !instr_mode then begin fprintf !outchan "module %sProfiling = Profiling;; " modprefix; - fprintf !outchan "let %s%s_cnt = Array.create 000000000" idprefix mod_name; + fprintf !outchan "let %s%s_cnt = Array.make 000000000" idprefix mod_name; pos_len := pos_out !outchan; fprintf !outchan " 0;; Profiling.counters := \ @@ -131,7 +131,7 @@ let init_rewrite modes mod_name = end let final_rewrite add_function = - to_insert := Sort.list (fun x y -> snd x < snd y) !to_insert; + to_insert := List.sort (fun x y -> compare (snd x) (snd y)) !to_insert; prof_counter := 0; List.iter add_function !to_insert; copy (in_channel_length !inchan); diff --git a/tools/untypeast.ml b/tools/untypeast.ml index b59443c595..58242fc23e 100644 --- a/tools/untypeast.ml +++ b/tools/untypeast.ml @@ -30,6 +30,9 @@ Some notes: *) +let string_is_prefix sub str = + let sublen = String.length sub in + String.length str >= sublen && String.sub str 0 sublen = sub let option f = function None -> None | Some e -> Some (f e) @@ -288,7 +291,7 @@ and untype_expression exp = in { uc with pc_lhs = pat }) exn_cases - in + in Pexp_match (untype_expression exp, merged_cases) | Texp_try (exp, cases) -> Pexp_try (untype_expression exp, untype_cases cases) @@ -586,7 +589,12 @@ and untype_core_type ct = Typ.mk ~loc:ct.ctyp_loc desc and untype_class_structure cs = - { pcstr_self = untype_pattern cs.cstr_self; + let rec remove_self = function + | { pat_desc = Tpat_alias (p, id, _s) } when string_is_prefix "selfpat-" id.Ident.name -> + remove_self p + | p -> p + in + { pcstr_self = untype_pattern (remove_self cs.cstr_self); pcstr_fields = List.map untype_class_field cs.cstr_fields; } @@ -596,6 +604,11 @@ and untype_row_field rf = Rtag (label, attrs, bool, List.map untype_core_type list) | Tinherit ct -> Rinherit (untype_core_type ct) +and is_self_pat = function + | { pat_desc = Tpat_alias(_pat, id, _) } -> + string_is_prefix "self-" (Ident.name id) + | _ -> false + and untype_class_field cf = let desc = match cf.cf_desc with Tcf_inherit (ovf, cl, super, _vals, _meths) -> @@ -609,8 +622,19 @@ and untype_class_field cf = | Tcf_method (lab, priv, Tcfk_virtual cty) -> Pcf_method (lab, priv, Cfk_virtual (untype_core_type cty)) | Tcf_method (lab, priv, Tcfk_concrete (o, exp)) -> + let remove_fun_self = function + | { exp_desc = Texp_function("", [case], _) } when is_self_pat case.c_lhs && case.c_guard = None -> case.c_rhs + | e -> e + in + let exp = remove_fun_self exp in Pcf_method (lab, priv, Cfk_concrete (o, untype_expression exp)) - | Tcf_initializer exp -> Pcf_initializer (untype_expression exp) + | Tcf_initializer exp -> + let remove_fun_self = function + | { exp_desc = Texp_function("", [case], _) } when is_self_pat case.c_lhs && case.c_guard = None -> case.c_rhs + | e -> e + in + let exp = remove_fun_self exp in + Pcf_initializer (untype_expression exp) | Tcf_attribute x -> Pcf_attribute x in { pcf_desc = desc; pcf_loc = cf.cf_loc; pcf_attributes = cf.cf_attributes } diff --git a/toplevel/genprintval.ml b/toplevel/genprintval.ml index 6519d3941c..98e369826d 100644 --- a/toplevel/genprintval.ml +++ b/toplevel/genprintval.ml @@ -258,7 +258,7 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct Oval_array [] | Tconstr (path, [ty_arg], _) when Path.same path Predef.path_lazy_t -> - if Lazy.lazy_is_val (O.obj obj) + if Lazy.is_val (O.obj obj) then let v = nest tree_of_val depth (Lazy.force (O.obj obj)) ty_arg in diff --git a/toplevel/opttopmain.ml b/toplevel/opttopmain.ml index 941c3ec26b..51d1daac55 100644 --- a/toplevel/opttopmain.ml +++ b/toplevel/opttopmain.ml @@ -81,6 +81,7 @@ module Options = Main_args.Make_opttop_options (struct let _real_paths = set real_paths let _rectypes = set recursive_types let _strict_sequence = set strict_sequence + let _strict_formats = set strict_formats let _S = set keep_asm_file let _short_paths = clear real_paths let _stdin () = file_argument "" diff --git a/toplevel/topdirs.ml b/toplevel/topdirs.ml index 5fdaa2cb50..1e260139e7 100644 --- a/toplevel/topdirs.ml +++ b/toplevel/topdirs.ml @@ -62,7 +62,7 @@ let check_consistency ppf filename cu = try List.iter (fun (name, crco) -> - Env.imported_units := name :: !Env.imported_units; + Env.add_import name; match crco with None -> () | Some crc-> diff --git a/toplevel/toploop.ml b/toplevel/toploop.ml index a7311d7b41..9ef3476a53 100644 --- a/toplevel/toploop.ml +++ b/toplevel/toploop.ml @@ -393,7 +393,7 @@ let _ = Compmisc.init_path false; List.iter (fun (name, crco) -> - Env.imported_units := name :: !Env.imported_units; + Env.add_import name; match crco with None -> () | Some crc-> diff --git a/toplevel/topmain.ml b/toplevel/topmain.ml index 045be0b75c..d1dbeca9d4 100644 --- a/toplevel/topmain.ml +++ b/toplevel/topmain.ml @@ -82,6 +82,7 @@ module Options = Main_args.Make_bytetop_options (struct let _short_paths = clear real_paths let _stdin () = file_argument "" let _strict_sequence = set strict_sequence + let _strict_formats = set strict_formats let _unsafe = set fast let _unsafe_string = set unsafe_string let _version () = print_version () diff --git a/toplevel/trace.ml b/toplevel/trace.ml index 60cfb95392..6690448363 100644 --- a/toplevel/trace.ml +++ b/toplevel/trace.ml @@ -96,14 +96,18 @@ let rec instrument_result env name ppf clos_typ = (* Same as instrument_result, but for a toplevel closure (modified in place) *) +exception Dummy +let _ = Dummy + let instrument_closure env name ppf clos_typ = match (Ctype.repr(Ctype.expand_head env clos_typ)).desc with | Tarrow(l, t1, t2, _) -> let trace_res = instrument_result env name ppf t2 in (fun actual_code closure arg -> if not !may_trace then begin - let res = invoke_traced_function actual_code closure arg - in res (* do not remove let, prevents tail-call to invoke_traced_ *) + try invoke_traced_function actual_code closure arg + with Dummy -> assert false + (* do not remove handler, prevents tail-call to invoke_traced_ *) end else begin may_trace := false; try diff --git a/typing/btype.ml b/typing/btype.ml index 6d1d8cdcd2..2df3270238 100644 --- a/typing/btype.ml +++ b/typing/btype.ml @@ -568,6 +568,9 @@ let label_name l = if is_optional l then String.sub l 1 (String.length l - 1) else l +let prefixed_label_name l = + if is_optional l then l else "~" ^ l + let rec extract_label_aux hd l = function [] -> raise Not_found | (l',t as p) :: ls -> diff --git a/typing/btype.mli b/typing/btype.mli index bf7f9558a8..af4653ff26 100644 --- a/typing/btype.mli +++ b/typing/btype.mli @@ -164,6 +164,10 @@ val forget_abbrev: val is_optional : label -> bool val label_name : label -> label + +(* Returns the label name with first character '?' or '~' as appropriate. *) +val prefixed_label_name : label -> label + val extract_label : label -> (label * 'a) list -> label * 'a * (label * 'a) list * (label * 'a) list diff --git a/typing/ctype.ml b/typing/ctype.ml index 30b9ac3361..9d59295949 100644 --- a/typing/ctype.ml +++ b/typing/ctype.ml @@ -293,7 +293,7 @@ let flatten_fields ty = (l, ty) in let (l, r) = flatten [] ty in - (Sort.list (fun (n, _, _) (n', _, _) -> n < n') l, r) + (List.sort (fun (n, _, _) (n', _, _) -> compare n n') l, r) let build_fields level = List.fold_right @@ -422,7 +422,7 @@ let rec class_type_arity = (* Miscellaneous operations on row types *) (*******************************************) -let sort_row_fields = Sort.list (fun (p,_) (q,_) -> p < q) +let sort_row_fields = List.sort (fun (p,_) (q,_) -> compare p q) let rec merge_rf r1 r2 pairs fi1 fi2 = match fi1, fi2 with @@ -1617,12 +1617,14 @@ let generic_private_abbrev env path = | _ -> false with Not_found -> false - (*****************) - (* Occur check *) - (*****************) - +let is_contractive env ty = + match (repr ty).desc with + Tconstr (p, _, _) -> + in_pervasives p || + (try is_datatype (Env.find_type p env) with Not_found -> false) + | _ -> true -exception Occur +(* Code moved to Typedecl (* The marks are already used by [expand_abbrev]... *) let visited = ref [] @@ -1665,6 +1667,14 @@ let correct_abbrev env path params ty = simple_abbrevs := Mnil; visited := []; raise exn +*) + + (*****************) + (* Occur check *) + (*****************) + + +exception Occur let rec occur_rec env visited ty0 ty = if ty == ty0 then raise Occur; @@ -2150,7 +2160,8 @@ and mcomp_type_decl type_pairs env p1 p2 tl1 tl2 = List.iter2 (fun i (t1,t2) -> if i then mcomp type_pairs env t1 t2) inj (List.combine tl1 tl2) - end else if non_aliasable p1 decl && non_aliasable p2 decl' then raise (Unify []) + end else if non_aliasable p1 decl && non_aliasable p2 decl' then + raise (Unify []) else match decl.type_kind, decl'.type_kind with | Type_record (lst,r), Type_record (lst',r') when r = r' -> @@ -2776,7 +2787,8 @@ let unify_gadt ~newtype_level:lev (env:Env.t ref) ty1 ty2 = try univar_pairs := []; newtype_level := Some lev; - set_mode_pattern ~generate:true ~injective:true (fun () -> unify env ty1 ty2); + set_mode_pattern ~generate:true ~injective:true + (fun () -> unify env ty1 ty2); newtype_level := None; TypePairs.clear unify_eq_set; with e -> diff --git a/typing/ctype.mli b/typing/ctype.mli index b807fbd098..37daf3a428 100644 --- a/typing/ctype.mli +++ b/typing/ctype.mli @@ -238,8 +238,9 @@ val nondep_class_declaration: val nondep_cltype_declaration: Env.t -> Ident.t -> class_type_declaration -> class_type_declaration (* Same for class type declarations. *) -val correct_abbrev: Env.t -> Path.t -> type_expr list -> type_expr -> unit +(*val correct_abbrev: Env.t -> Path.t -> type_expr list -> type_expr -> unit*) val cyclic_abbrev: Env.t -> Ident.t -> type_expr -> bool +val is_contractive: Env.t -> type_expr -> bool val normalize_type: Env.t -> type_expr -> unit val closed_schema: type_expr -> bool diff --git a/typing/datarepr.ml b/typing/datarepr.ml index ff6117bf41..c4d302537e 100644 --- a/typing/datarepr.ml +++ b/typing/datarepr.ml @@ -219,7 +219,7 @@ let dummy_label = } let label_descrs ty_res lbls repres priv = - let all_labels = Array.create (List.length lbls) dummy_label in + let all_labels = Array.make (List.length lbls) dummy_label in let rec describe_labels num = function [] -> [] | l :: rest -> diff --git a/typing/env.ml b/typing/env.ml index 448f2a881d..5b89b0bd99 100644 --- a/typing/env.ml +++ b/typing/env.ml @@ -164,6 +164,9 @@ module EnvTbl = type type_descriptions = constructor_description list * label_description list * bool +let in_signature_flag = 0x01 +let implicit_coercion_flag = 0x02 + type t = { values: (Path.t * value_description) EnvTbl.t; constrs: constructor_description EnvTbl.t; @@ -178,7 +181,7 @@ type t = { summary: summary; local_constraints: bool; gadt_instances: (int * TypeSet.t ref) list; - in_signature: bool; + flags: int; } and module_components = @@ -221,11 +224,17 @@ let empty = { components = EnvTbl.empty; classes = EnvTbl.empty; cltypes = EnvTbl.empty; summary = Env_empty; local_constraints = false; gadt_instances = []; - in_signature = false; + flags = 0; functor_args = Ident.empty; } -let in_signature env = {env with in_signature = true} +let in_signature env = + {env with flags = env.flags lor in_signature_flag} +let implicit_coercion env = + {env with flags = env.flags lor implicit_coercion_flag} + +let is_in_signature env = env.flags land in_signature_flag <> 0 +let is_implicit_coercion env = env.flags land implicit_coercion_flag <> 0 let diff_keys is_local tbl1 tbl2 = let keys2 = EnvTbl.keys tbl2 in @@ -287,6 +296,7 @@ type pers_struct = ps_sig: signature; ps_comps: module_components; ps_crcs: (string * Digest.t option) list; + mutable ps_crcs_checked: bool; ps_filename: string; ps_flags: pers_flags list } @@ -296,22 +306,31 @@ let persistent_structures = (* Consistency between persistent structures *) let crc_units = Consistbl.create() -let imported_units = ref ([] : string list) + +module StringSet = + Set.Make(struct type t = string let compare = String.compare end) + +let imported_units = ref StringSet.empty + +let add_import s = + imported_units := StringSet.add s !imported_units let clear_imports () = Consistbl.clear crc_units; - imported_units := [] + imported_units := StringSet.empty let check_consistency ps = + if not ps.ps_crcs_checked then try List.iter (fun (name, crco) -> match crco with None -> () | Some crc -> - imported_units := name :: !imported_units; + add_import name; Consistbl.check crc_units name crc ps.ps_filename) - ps.ps_crcs + ps.ps_crcs; + ps.ps_crcs_checked <- true; with Consistbl.Inconsistency(name, source, auth) -> error (Inconsistent_import(name, auth, source)) @@ -333,10 +352,12 @@ let read_pers_struct modname filename = ps_comps = comps; ps_crcs = crcs; ps_filename = filename; - ps_flags = flags } in + ps_flags = flags; + ps_crcs_checked = false; + } in if ps.ps_name <> modname then error (Illegal_renaming(modname, ps.ps_name, filename)); - imported_units := name :: !imported_units; + add_import name; List.iter (function Rectypes -> if not !Clflags.recursive_types then @@ -760,22 +781,26 @@ and lookup_class = and lookup_cltype = lookup (fun env -> env.cltypes) (fun sc -> sc.comp_cltypes) -let mark_value_used name vd = - try Hashtbl.find value_declarations (name, vd.val_loc) () - with Not_found -> () +let mark_value_used env name vd = + if not (is_implicit_coercion env) then + try Hashtbl.find value_declarations (name, vd.val_loc) () + with Not_found -> () -let mark_type_used name vd = - try Hashtbl.find type_declarations (name, vd.type_loc) () - with Not_found -> () +let mark_type_used env name vd = + if not (is_implicit_coercion env) then + try Hashtbl.find type_declarations (name, vd.type_loc) () + with Not_found -> () -let mark_constructor_used usage name vd constr = - try Hashtbl.find used_constructors (name, vd.type_loc, constr) usage - with Not_found -> () +let mark_constructor_used usage env name vd constr = + if not (is_implicit_coercion env) then + try Hashtbl.find used_constructors (name, vd.type_loc, constr) usage + with Not_found -> () -let mark_extension_used usage ext name = - let ty_name = Path.last ext.ext_type_path in - try Hashtbl.find used_constructors (ty_name, ext.ext_loc, name) usage - with Not_found -> () +let mark_extension_used usage env ext name = + if not (is_implicit_coercion env) then + let ty_name = Path.last ext.ext_type_path in + try Hashtbl.find used_constructors (ty_name, ext.ext_loc, name) usage + with Not_found -> () let set_value_used_callback name vd callback = let key = (name, vd.val_loc) in @@ -801,12 +826,12 @@ let set_type_used_callback name td callback = let lookup_value lid env = let (_, desc) as r = lookup_value lid env in - mark_value_used (Longident.last lid) desc; + mark_value_used env (Longident.last lid) desc; r let lookup_type lid env = let (path, (decl, _)) = lookup_type lid env in - mark_type_used (Longident.last lid) decl; + mark_type_used env (Longident.last lid) decl; (path, decl) (* [path] must be the path to a type, not to a module ! *) @@ -819,7 +844,7 @@ let path_subst_last path id = let mark_type_path env path = try let decl = find_type path env in - mark_type_used (Path.last path) decl + mark_type_used env (Path.last path) decl with Not_found -> () let ty_path t = @@ -851,7 +876,8 @@ let lookup_all_constructors lid env = Not_found when is_lident lid -> [] let mark_constructor usage env name desc = - match desc.cstr_tag with + if not (is_implicit_coercion env) + then match desc.cstr_tag with | Cstr_extension _ -> begin let ty_path = ty_path desc.cstr_res in @@ -863,7 +889,7 @@ let mark_constructor usage env name desc = let ty_path = ty_path desc.cstr_res in let ty_decl = try find_type ty_path env with Not_found -> assert false in let ty_name = Path.last ty_path in - mark_constructor_used usage ty_name ty_decl name + mark_constructor_used usage env ty_name ty_decl name let lookup_label lid env = match lookup_all_labels lid env with @@ -1346,7 +1372,7 @@ and store_type ~check slot id path info env renv = if not (ty = "" || ty.[0] = '_') then !add_delayed_check_forward (fun () -> - if not env.in_signature && not used.cu_positive then + if not (is_in_signature env) && not used.cu_positive then Location.prerr_warning loc (Warnings.Unused_constructor (c, used.cu_pattern, used.cu_privatize))) @@ -1395,7 +1421,7 @@ and store_extension ?rebind ~check slot id path ext env renv = Hashtbl.add used_constructors k (add_constructor_usage used); !add_delayed_check_forward (fun () -> - if not env.in_signature && not used.cu_positive then + if not (is_in_signature env) && not used.cu_positive then Location.prerr_warning loc (Warnings.Unused_extension (n, used.cu_pattern, used.cu_privatize) @@ -1633,7 +1659,7 @@ let crc_of_unit name = (* Return the list of imported interfaces with their CRCs *) let imports() = - Consistbl.extract !imported_units crc_units + Consistbl.extract (StringSet.elements !imported_units) crc_units (* Save a signature to a file *) @@ -1664,10 +1690,12 @@ let save_signature_with_imports sg modname filename imports = ps_comps = comps; ps_crcs = (cmi.cmi_name, Some crc) :: imports; ps_filename = filename; - ps_flags = cmi.cmi_flags } in + ps_flags = cmi.cmi_flags; + ps_crcs_checked = false; + } in Hashtbl.add persistent_structures modname (Some ps); Consistbl.set crc_units modname crc filename; - imported_units := modname :: !imported_units; + add_import modname; sg with exn -> close_out oc; @@ -1787,7 +1815,7 @@ let keep_only_summary env = empty with summary = env.summary; local_constraints = env.local_constraints; - in_signature = env.in_signature; + flags = env.flags; } in last_env := env; @@ -1800,7 +1828,7 @@ let env_of_only_summary env_from_summary env = let new_env = env_from_summary env.summary Subst.identity in { new_env with local_constraints = env.local_constraints; - in_signature = env.in_signature; + flags = env.flags; } (* Error report *) @@ -1808,10 +1836,10 @@ let env_of_only_summary env_from_summary env = open Format let report_error ppf = function - | Illegal_renaming(name, modname, filename) -> fprintf ppf + | Illegal_renaming(modname, ps_name, filename) -> fprintf ppf "Wrong file naming: %a@ contains the compiled interface for @ \ %s when %s was expected" - Location.print_filename filename name modname + Location.print_filename filename ps_name modname | Inconsistent_import(name, source1, source2) -> fprintf ppf "@[<hov>The files %a@ and %a@ \ make inconsistent assumptions@ over interface %s@]" diff --git a/typing/env.mli b/typing/env.mli index eae5bc5fad..f53cb92072 100644 --- a/typing/env.mli +++ b/typing/env.mli @@ -171,7 +171,7 @@ val imports: unit -> (string * Digest.t option) list (* Direct access to the table of imported compilation units with their CRC *) val crc_units: Consistbl.t -val imported_units: string list ref +val add_import: string -> unit (* Summaries -- compact representation of an environment, to be exported in debugging information. *) @@ -200,18 +200,19 @@ open Format val report_error: formatter -> error -> unit -val mark_value_used: string -> value_description -> unit -val mark_type_used: string -> type_declaration -> unit +val mark_value_used: t -> string -> value_description -> unit +val mark_type_used: t -> string -> type_declaration -> unit type constructor_usage = Positive | Pattern | Privatize val mark_constructor_used: - constructor_usage -> string -> type_declaration -> string -> unit + constructor_usage -> t -> string -> type_declaration -> string -> unit val mark_constructor: constructor_usage -> t -> string -> constructor_description -> unit val mark_extension_used: - constructor_usage -> extension_constructor -> string -> unit + constructor_usage -> t -> extension_constructor -> string -> unit val in_signature: t -> t +val implicit_coercion: t -> t val set_value_used_callback: string -> value_description -> (unit -> unit) -> unit diff --git a/typing/envaux.ml b/typing/envaux.ml index af86fd25be..708da443d2 100644 --- a/typing/envaux.ml +++ b/typing/envaux.ml @@ -28,7 +28,7 @@ let reset_cache () = Env.reset_cache() let extract_sig env mty = - match Mtype.scrape env mty with + match Env.scrape_alias env mty with Mty_signature sg -> sg | _ -> fatal_error "Envaux.extract_sig" diff --git a/typing/includecore.ml b/typing/includecore.ml index 0c5141c05f..c4c5e64c4b 100644 --- a/typing/includecore.ml +++ b/typing/includecore.ml @@ -230,7 +230,7 @@ let type_declarations ?(equality = false) env name decl1 id decl2 = let mark cstrs usage name decl = List.iter (fun c -> - Env.mark_constructor_used usage name decl + Env.mark_constructor_used usage env name decl (Ident.name c.Types.cd_id)) cstrs in @@ -293,7 +293,7 @@ let extension_constructors env id ext1 ext2 = if ext1.ext_private = Private || ext2.ext_private = Public then Env.Positive else Env.Privatize in - Env.mark_extension_used usage ext1 (Ident.name id); + Env.mark_extension_used usage env ext1 (Ident.name id); let ty1 = Btype.newgenty (Tconstr(ext1.ext_type_path, ext1.ext_type_params, ref Mnil)) in diff --git a/typing/includemod.ml b/typing/includemod.ml index 57fec56142..41444e6aac 100644 --- a/typing/includemod.ml +++ b/typing/includemod.ml @@ -52,7 +52,7 @@ exception Error of error list let value_descriptions env cxt subst id vd1 vd2 = Cmt_format.record_value_dependency vd1 vd2; - Env.mark_value_used (Ident.name id) vd1; + Env.mark_value_used env (Ident.name id) vd1; let vd2 = Subst.value_description subst vd2 in try Includecore.value_descriptions env vd1 vd2 @@ -62,7 +62,7 @@ let value_descriptions env cxt subst id vd1 vd2 = (* Inclusion between type declarations *) let type_declarations env cxt subst id decl1 decl2 = - Env.mark_type_used (Ident.name id) decl1; + Env.mark_type_used env (Ident.name id) decl1; let decl2 = Subst.type_declaration subst decl2 in let err = Includecore.type_declarations env (Ident.name id) decl1 id decl2 in if err <> [] then @@ -157,6 +157,39 @@ let is_runtime_component = function | Sig_module(_,_,_) | Sig_class(_, _,_) -> true +(* Print a coercion *) + +let rec print_list pr ppf = function + [] -> () + | [a] -> pr ppf a + | a :: l -> pr ppf a; Format.fprintf ppf ";@ "; print_list pr ppf l +let print_list pr ppf l = + Format.fprintf ppf "[@[%a@]]" (print_list pr) l + +let rec print_coercion ppf c = + let pr fmt = Format.fprintf ppf fmt in + match c with + Tcoerce_none -> pr "id" + | Tcoerce_structure (fl, nl) -> + pr "@[<2>struct@ %a@ %a@]" + (print_list print_coercion2) fl + (print_list print_coercion3) nl + | Tcoerce_functor (inp, out) -> + pr "@[<2>functor@ (%a)@ (%a)@]" + print_coercion inp + print_coercion out + | Tcoerce_primitive pd -> + pr "prim %s" pd.Primitive.prim_name + | Tcoerce_alias (p, c) -> + pr "@[<2>alias %a@ (%a)@]" + Printtyp.path p + print_coercion c +and print_coercion2 ppf (n, c) = + Format.fprintf ppf "@[%d,@ %a@]" n print_coercion c +and print_coercion3 ppf (i, n, c) = + Format.fprintf ppf "@[%s, %d,@ %a@]" + (Ident.unique_name i) n print_coercion c + (* Simplify a structure coercion *) let simplify_structure_coercion cc id_pos_list = @@ -441,6 +474,15 @@ let signatures env sig1 sig2 = signatures env [] Subst.identity sig1 sig2 let type_declarations env id decl1 decl2 = type_declarations env [] Subst.identity id decl1 decl2 +(* +let modtypes env m1 m2 = + let c = modtypes env m1 m2 in + Format.eprintf "@[<2>modtypes@ %a@ %a =@ %a@]@." + Printtyp.modtype m1 Printtyp.modtype m2 + print_coercion c; + c +*) + (* Error report *) open Format diff --git a/typing/includemod.mli b/typing/includemod.mli index 7ea48f8619..5bc3c336bb 100644 --- a/typing/includemod.mli +++ b/typing/includemod.mli @@ -22,6 +22,7 @@ val compunit: Env.t -> string -> signature -> string -> signature -> module_coercion val type_declarations: Env.t -> Ident.t -> type_declaration -> type_declaration -> unit +val print_coercion: formatter -> module_coercion -> unit type symptom = Missing_field of Ident.t * Location.t * string (* kind *) diff --git a/typing/mtype.ml b/typing/mtype.ml index 4e1e0a4f7a..4a68d23859 100644 --- a/typing/mtype.ml +++ b/typing/mtype.ml @@ -241,8 +241,11 @@ and no_code_needed_sig env sg = let rec contains_type env = function Mty_ident path -> - (try Misc.may (contains_type env) (Env.find_modtype path env).mtd_type - with Not_found -> raise Exit) + begin try match (Env.find_modtype path env).mtd_type with + | None -> raise Exit (* PR#6427 *) + | Some mty -> contains_type env mty + with Not_found -> raise Exit + end | Mty_signature sg -> contains_type_sig env sg | Mty_functor (_, _, body) -> diff --git a/typing/parmatch.ml b/typing/parmatch.ml index 8a840b5426..41cd493fef 100644 --- a/typing/parmatch.ml +++ b/typing/parmatch.ml @@ -693,8 +693,8 @@ let should_extend ext env = match ext with (* complement constructor tags *) let complete_tags nconsts nconstrs tags = - let seen_const = Array.create nconsts false - and seen_constr = Array.create nconstrs false in + let seen_const = Array.make nconsts false + and seen_constr = Array.make nconstrs false in List.iter (function | Cstr_constant i -> seen_const.(i) <- true diff --git a/typing/printtyp.ml b/typing/printtyp.ml index 0e928c8822..c21c2d63c4 100644 --- a/typing/printtyp.ml +++ b/typing/printtyp.ml @@ -232,7 +232,7 @@ module Path2 = struct | _ -> Pervasives.compare p1 p2 end module PathMap = Map.Make(Path2) -let printing_map = ref (Lazy.lazy_from_val PathMap.empty) +let printing_map = ref (Lazy.from_val PathMap.empty) let same_type t t' = repr t == repr t' @@ -936,6 +936,7 @@ let extension_constructor id ppf ext = (* Print a value declaration *) let tree_of_value_description id decl = + (* Format.eprintf "@[%a@]@." raw_type_expr decl.val_type; *) let id = Ident.name id in let ty = tree_of_type_scheme decl.val_type in let prims = diff --git a/typing/printtyped.ml b/typing/printtyped.ml index 608fb44a06..5184b19e5d 100644 --- a/typing/printtyped.ml +++ b/typing/printtyped.ml @@ -513,12 +513,11 @@ and class_expr i ppf x = | Tcl_structure (cs) -> line i ppf "Pcl_structure\n"; class_structure i ppf cs; - | Tcl_fun (l, eo, p, e, _) -> assert false (* TODO *) -(* line i ppf "Pcl_fun\n"; + | Tcl_fun (l, p, _, ce, _) -> + line i ppf "Pcl_fun\n"; label i ppf l; - option i expression ppf eo; pattern i ppf p; - class_expr i ppf e; *) + class_expr i ppf ce | Tcl_apply (ce, l) -> line i ppf "Pcl_apply\n"; class_expr i ppf ce; @@ -531,46 +530,47 @@ and class_expr i ppf x = | Tcl_constraint (ce, Some ct, _, _, _) -> line i ppf "Pcl_constraint\n"; class_expr i ppf ce; - class_type i ppf ct; - | Tcl_constraint (_, None, _, _, _) -> assert false - (* TODO : is it possible ? see parsetree *) + class_type i ppf ct + | Tcl_constraint (ce, None, _, _, _) -> class_expr i ppf ce and class_structure i ppf { cstr_self = p; cstr_fields = l } = line i ppf "class_structure\n"; pattern (i+1) ppf p; list (i+1) class_field ppf l; -and class_field i ppf x = assert false (* TODO *) -(* let loc = x.cf_loc in +and class_field i ppf x = + line i ppf "class_field %a\n" fmt_location x.cf_loc; + let i = i + 1 in + attributes i ppf x.cf_attributes; match x.cf_desc with - | Tcf_inher (ovf, ce, so) -> - line i ppf "Pcf_inher %a\n" fmt_override_flag ovf; + | Tcf_inherit (ovf, ce, so, _, _) -> + line i ppf "Pcf_inherit %a\n" fmt_override_flag ovf; class_expr (i+1) ppf ce; option (i+1) string ppf so; - | Tcf_valvirt (s, mf, ct) -> - line i ppf "Pcf_valvirt \"%s\" %a %a\n" - s.txt fmt_mutable_flag mf fmt_location loc; - core_type (i+1) ppf ct; - | Tcf_val (s, mf, ovf, e) -> - line i ppf "Pcf_val \"%s\" %a %a %a\n" - s.txt fmt_mutable_flag mf fmt_override_flag ovf fmt_location loc; - expression (i+1) ppf e; - | Tcf_virt (s, pf, ct) -> - line i ppf "Pcf_virt \"%s\" %a %a\n" - s.txt fmt_private_flag pf fmt_location loc; - core_type (i+1) ppf ct; - | Tcf_meth (s, pf, ovf, e) -> - line i ppf "Pcf_meth \"%s\" %a %a %a\n" - s.txt fmt_private_flag pf fmt_override_flag ovf fmt_location loc; - expression (i+1) ppf e; - | Tcf_constr (ct1, ct2) -> - line i ppf "Pcf_constr %a\n" fmt_location loc; + | Tcf_val (s, mf, _, k, _) -> + line i ppf "Pcf_val \"%s\" %a\n" s.txt fmt_mutable_flag mf; + class_field_kind (i+1) ppf k + | Tcf_method (s, pf, k) -> + line i ppf "Pcf_method \"%s\" %a\n" s.txt fmt_private_flag pf; + class_field_kind (i+1) ppf k + | Tcf_constraint (ct1, ct2) -> + line i ppf "Pcf_constraint\n"; core_type (i+1) ppf ct1; core_type (i+1) ppf ct2; - | Tcf_init (e) -> - line i ppf "Pcf_init\n"; + | Tcf_initializer (e) -> + line i ppf "Pcf_initializer\n"; expression (i+1) ppf e; -*) + | Tcf_attribute (s, arg) -> + line i ppf "Pcf_attribute \"%s\"\n" s.txt; + Printast.payload i ppf arg + +and class_field_kind i ppf = function + | Tcfk_concrete (o, e) -> + line i ppf "Concrete %a\n" fmt_override_flag o; + expression i ppf e + | Tcfk_virtual t -> + line i ppf "Virtual\n"; + core_type i ppf t and class_declaration i ppf x = line i ppf "class_declaration %a\n" fmt_location x.ci_loc; @@ -698,10 +698,7 @@ and module_expr i ppf x = line i ppf "Pmod_constraint\n"; module_expr i ppf me; module_type i ppf mt; - | Tmod_constraint (me, _, Tmodtype_implicit, _) -> assert false (* TODO *) -(* line i ppf "Pmod_constraint\n"; - module_expr i ppf me; - module_type i ppf mt; *) + | Tmod_constraint (me, _, Tmodtype_implicit, _) -> module_expr i ppf me | Tmod_unpack (e, _) -> line i ppf "Pmod_unpack\n"; expression i ppf e; diff --git a/typing/typeclass.ml b/typing/typeclass.ml index 3bed6ed7d3..33b776befd 100644 --- a/typing/typeclass.ml +++ b/typing/typeclass.ml @@ -438,7 +438,7 @@ and class_signature env {pcsig_self=sty; pcsig_fields=sign} = (* Class type fields *) Typetexp.warning_enter_scope (); - let (fields, val_sig, concr_meths, inher) = + let (rev_fields, val_sig, concr_meths, inher) = List.fold_left (class_type_field env self_type meths) ([], Vars.empty, Concr.empty, []) sign @@ -450,9 +450,9 @@ and class_signature env {pcsig_self=sty; pcsig_fields=sign} = csig_inher = inher} in { csig_self = self_cty; - csig_fields = fields; + csig_fields = List.rev rev_fields; csig_type = cty; - } + } and class_type env scty = let cltyp desc typ = @@ -968,6 +968,9 @@ and class_expr cl_num val_env met_env scl = cl_attributes = scl.pcl_attributes; } | Pcl_apply (scl', sargs) -> + if sargs = [] then + Syntaxerr.ill_formed_ast scl.pcl_loc + "Function application with no argument."; if !Clflags.principal then Ctype.begin_def (); let cl = class_expr cl_num val_env met_env scl' in if !Clflags.principal then begin diff --git a/typing/typecore.ml b/typing/typecore.ml index 6494f22872..9b8b0f2ab0 100644 --- a/typing/typecore.ml +++ b/typing/typecore.ml @@ -609,7 +609,7 @@ end) = struct let lookup_from_type env tpath lid = let (_, _, inlined) as descrs = Env.find_type_descrs tpath env in let descrs = get_descrs descrs in - Env.mark_type_used (Path.last tpath) (Env.find_type tpath env); + Env.mark_type_used env (Path.last tpath) (Env.find_type tpath env); match lid.txt with Longident.Lident s -> begin try @@ -995,6 +995,8 @@ let rec type_pat ~constrs ~labels ~no_existentials ~mode ~env sp expected_ty = | Ppat_interval _ -> raise (Error (loc, !env, Invalid_interval)) | Ppat_tuple spl -> + if List.length spl < 2 then + Syntaxerr.ill_formed_ast loc "Tuples must have at least 2 components."; let spl_ann = List.map (fun p -> (p,newvar ())) spl in let ty = newty (Ttuple(List.map snd spl_ann)) in unify_pat_types loc !env ty expected_ty; @@ -1087,6 +1089,8 @@ let rec type_pat ~constrs ~labels ~no_existentials ~mode ~env sp expected_ty = pat_attributes = sp.ppat_attributes; pat_env = !env } | Ppat_record(lid_sp_list, closed) -> + if lid_sp_list = [] then + Syntaxerr.ill_formed_ast loc "Records cannot be empty."; let opath, record_ty = try let (p0, p,_) = extract_concrete_record !env expected_ty in @@ -1350,11 +1354,17 @@ let type_self_pattern cl_num privty val_env met_env par_env spat = let delayed_checks = ref [] let reset_delayed_checks () = delayed_checks := [] -let add_delayed_check f = delayed_checks := f :: !delayed_checks +let add_delayed_check f = + delayed_checks := (f, Warnings.backup ()) :: !delayed_checks + let force_delayed_checks () = (* checks may change type levels *) let snap = Btype.snapshot () in - List.iter (fun f -> f ()) (List.rev !delayed_checks); + let w_old = Warnings.backup () in + List.iter + (fun (f, w) -> Warnings.restore w; f ()) + (List.rev !delayed_checks); + Warnings.restore w_old; reset_delayed_checks (); Btype.backtrack snap @@ -1876,6 +1886,8 @@ and type_expect_ ?in_function env sexp ty_expected = type_function ?in_function loc sexp.pexp_attributes env ty_expected "" caselist | Pexp_apply(sfunct, sargs) -> + if sargs = [] then + Syntaxerr.ill_formed_ast loc "Function application with no argument."; begin_def (); (* one more level for non-returning functions *) if !Clflags.principal then begin_def (); let funct = type_exp env sfunct in @@ -1945,6 +1957,8 @@ and type_expect_ ?in_function env sexp ty_expected = exp_attributes = sexp.pexp_attributes; exp_env = env } | Pexp_tuple sexpl -> + if List.length sexpl < 2 then + Syntaxerr.ill_formed_ast loc "Tuples must have at least 2 components."; let subtypes = List.map (fun _ -> newgenvar ()) sexpl in let to_unify = newgenty (Ttuple subtypes) in unify_exp_types loc env to_unify ty_expected; @@ -1995,6 +2009,8 @@ and type_expect_ ?in_function env sexp ty_expected = exp_env = env } end | Pexp_record(lid_sexp_list, opt_sexp) -> + if lid_sexp_list = [] then + Syntaxerr.ill_formed_ast loc "Records cannot be empty."; let opt_exp = match opt_sexp with None -> None @@ -2963,7 +2979,8 @@ and type_format loc str env = | End_of_format -> mk_constr "End_of_format" [] in - let Fmt_EBB fmt = fmt_ebb_of_string str in + let legacy_behavior = not !Clflags.strict_formats in + let Fmt_EBB fmt = fmt_ebb_of_string ~legacy_behavior str in mk_constr "Format" [ mk_fmt fmt; mk_string str ] )) with Failure msg -> @@ -3641,7 +3658,7 @@ and type_let ?(check = fun s -> Warnings.Unused_var s) slot := (name, vd) :: !slot; rec_needed := true | None -> List.iter - (fun (name, vd) -> Env.mark_value_used name vd) + (fun (name, vd) -> Env.mark_value_used env name vd) (get_ref slot); used := true; some_used := true @@ -3795,7 +3812,7 @@ let report_error env ppf = function let print_label ppf = function | "" -> fprintf ppf "without label" | l -> - fprintf ppf "with label %s%s" (if is_optional l then "" else "~") l + fprintf ppf "with label %s" (prefixed_label_name l) in reset_and_mark_loops ty; fprintf ppf @@ -3884,7 +3901,8 @@ let report_error env ppf = function | Abstract_wrong_label (l, ty) -> let label_mark = function | "" -> "but its first argument is not labelled" - | l -> sprintf "but its first argument is labelled ~%s" l in + | l -> sprintf "but its first argument is labelled %s" + (prefixed_label_name l) in reset_and_mark_loops ty; fprintf ppf "@[<v>@[<2>This function should have type@ %a@]@,%s@]" type_expr ty (label_mark l) diff --git a/typing/typedecl.ml b/typing/typedecl.ml index aad2f69614..54cce8dcce 100644 --- a/typing/typedecl.ml +++ b/typing/typedecl.ml @@ -25,6 +25,7 @@ type error = | Too_many_constructors | Duplicate_label of string | Recursive_abbrev of string + | Cycle_in_def of string * type_expr | Definition_mismatch of type_expr * Includecore.type_mismatch list | Constraint_failed of type_expr * type_expr | Inconsistent_constraint of Env.t * (type_expr * type_expr) list @@ -145,7 +146,9 @@ let make_params env params = in List.map make_param params -let transl_labels env closed lbls = +let transl_labels loc env closed lbls = + if lbls = [] then + Syntaxerr.ill_formed_ast loc "Records cannot be empty."; let all_labels = ref StringSet.empty in List.iter (fun {pld_name = {txt=name; loc}} -> @@ -175,23 +178,23 @@ let transl_labels env closed lbls = lbls in lbls, lbls' -let transl_constructor_arguments env closed ty_name c_name = function +let transl_constructor_arguments loc env closed ty_name c_name = function | Pcstr_tuple l -> let l = List.map (transl_simple_type env closed) l in Types.Cstr_tuple (List.map (fun t -> t.ctyp_type) l), Cstr_tuple l | Pcstr_record l -> - let lbls, lbls' = transl_labels env closed l in + let lbls, lbls' = transl_labels loc env closed l in let id = Ident.create (ty_name ^ "." ^ c_name) in Types.Cstr_record (id, lbls'), Cstr_record lbls -let make_constructor env type_path type_params c_name sargs sret_type = +let make_constructor loc env type_path type_params c_name sargs sret_type = let ty_name = Path.last type_path in match sret_type with | None -> let args, targs = - transl_constructor_arguments env true ty_name c_name sargs + transl_constructor_arguments loc env true ty_name c_name sargs in targs, None, args, None | Some sret_type -> @@ -200,15 +203,16 @@ let make_constructor env type_path type_params c_name sargs sret_type = let z = narrow () in reset_type_variables (); let args, targs = - transl_constructor_arguments env false ty_name c_name sargs + transl_constructor_arguments loc env false ty_name c_name sargs in let tret_type = transl_simple_type env false sret_type in let ret_type = tret_type.ctyp_type in begin match (Ctype.repr ret_type).desc with Tconstr (p', _, _) when Path.same type_path p' -> () - | _ -> raise (Error (sret_type.ptyp_loc, Constraint_failed - (ret_type, Ctype.newconstr type_path type_params))) + | _ -> + raise (Error (sret_type.ptyp_loc, Constraint_failed + (ret_type, Ctype.newconstr type_path type_params))) end; widen z; targs, Some tret_type, args, Some ret_type @@ -229,6 +233,9 @@ let transl_declaration env sdecl id = match sdecl.ptype_kind with Ptype_abstract -> Ttype_abstract, Type_abstract | Ptype_variant scstrs -> + if scstrs = [] then + Syntaxerr.ill_formed_ast sdecl.ptype_loc + "Variant types cannot be empty."; let all_constrs = ref StringSet.empty in List.iter (fun {pcd_name = {txt = name}} -> @@ -243,7 +250,7 @@ let transl_declaration env sdecl id = let make_cstr scstr = let name = Ident.create scstr.pcd_name.txt in let targs, tret_type, args, ret_type = - make_constructor env (Path.Pident id) params + make_constructor scstr.pcd_loc env (Path.Pident id) params scstr.pcd_name.txt scstr.pcd_args scstr.pcd_res in @@ -267,7 +274,7 @@ let transl_declaration env sdecl id = let tcstrs, cstrs = List.split (List.map make_cstr scstrs) in Ttype_variant tcstrs, Type_variant cstrs | Ptype_record lbls -> - let lbls, lbls' = transl_labels env true lbls in + let lbls, lbls' = transl_labels sdecl.ptype_loc env true lbls in let rep = if List.for_all (fun l -> is_float env l.Types.ld_type) lbls' then Record_float @@ -343,6 +350,7 @@ let generalize_decl decl = (* Check that all constraints are enforced *) module TypeSet = Btype.TypeSet +module TypeMap = Btype.TypeMap let rec check_constraints_rec env loc visited ty = let ty = Ctype.repr ty in @@ -372,7 +380,8 @@ let check_constraints_labels env visited l pl = let rec get_loc name = function [] -> assert false | pld :: tl -> - if name = pld.pld_name.txt then pld.pld_type.ptyp_loc else get_loc name tl + if name = pld.pld_name.txt then pld.pld_type.ptyp_loc + else get_loc name tl in List.iter (fun {Types.ld_id=name; ld_type=ty} -> @@ -474,14 +483,61 @@ let check_abbrev env sdecl (id, decl) = (* Check that recursion is well-founded *) -let check_well_founded env loc path decl = - Misc.may - (fun body -> - try Ctype.correct_abbrev env path decl.type_params body with - | Ctype.Recursive_abbrev -> - raise(Error(loc, Recursive_abbrev (Path.name path))) - | Ctype.Unify trace -> raise(Error(loc, Type_clash (env, trace)))) - decl.type_manifest +let check_well_founded env loc path to_check ty = + let visited = ref TypeMap.empty in + let rec check ty0 exp_nodes ty = + let ty = Btype.repr ty in + if TypeSet.mem ty exp_nodes then begin + (*Format.eprintf "@[%a@]@." Printtyp.raw_type_expr ty;*) + if match ty0.desc with + | Tconstr (p, _, _) -> Path.same p path + | _ -> false + then raise (Error (loc, Recursive_abbrev (Path.name path))) + else raise (Error (loc, Cycle_in_def (Path.name path, ty0))) + end; + let (fini, exp_nodes) = + try + let prev = TypeMap.find ty !visited in + if TypeSet.subset exp_nodes prev then (true, exp_nodes) else + (false, TypeSet.union exp_nodes prev) + with Not_found -> + (false, exp_nodes) + in + let snap = Btype.snapshot () in + if fini then () else try + visited := TypeMap.add ty exp_nodes !visited; + match ty.desc with + | Tconstr(p, args, _) + when not (TypeSet.is_empty exp_nodes) || to_check p -> + let ty' = Ctype.try_expand_once_opt env ty in + let ty0 = if TypeSet.is_empty exp_nodes then ty else ty0 in + check ty0 (TypeSet.add ty exp_nodes) ty' + | _ -> raise Ctype.Cannot_expand + with + | Ctype.Cannot_expand -> + let nodes = + if !Clflags.recursive_types && Ctype.is_contractive env ty + || match ty.desc with Tobject _ | Tvariant _ -> true | _ -> false + then TypeSet.empty + else exp_nodes in + Btype.iter_type_expr (check ty0 nodes) ty + | Ctype.Unify _ -> + (* Will be detected by check_recursion *) + Btype.backtrack snap + in + check ty TypeSet.empty ty + +let check_well_founded_manifest env loc path decl = + if decl.type_manifest = None then () else + let args = List.map (fun _ -> Ctype.newvar()) decl.type_params in + check_well_founded env loc path (Path.same path) (Ctype.newconstr path args) + +let check_well_founded_decl env loc path decl to_check = + let open Btype in + let it = + {type_iterators with + it_type_expr = (fun _ -> check_well_founded env loc path to_check)} in + it.it_type_declaration it (Ctype.instance_declaration decl) (* Check for ill-defined abbrevs *) @@ -541,16 +597,13 @@ let check_recursion env loc path decl to_check = check_regular path args [] body) decl.type_manifest -let check_abbrev_recursion env id_loc_list tdecl = +let check_abbrev_recursion env id_loc_list to_check tdecl = let decl = tdecl.typ_type in let id = tdecl.typ_id in - check_recursion env (List.assoc id id_loc_list) (Path.Pident id) decl - (function Path.Pident id -> List.mem_assoc id id_loc_list | _ -> false) + check_recursion env (List.assoc id id_loc_list) (Path.Pident id) decl to_check (* Compute variance *) -module TypeMap = Btype.TypeMap - let get_variance ty visited = try TypeMap.find ty !visited with Not_found -> Variance.null @@ -804,7 +857,8 @@ let compute_variance_decl env check decl (required, loc as rloc) = else begin let mn = List.map (fun (_,ty) -> (Types.Cstr_tuple [ty],None)) mn in - let tll = mn @ List.map (fun c -> c.Types.cd_args, c.Types.cd_res) tll in + let tll = + mn @ List.map (fun c -> c.Types.cd_args, c.Types.cd_res) tll in match List.map (compute_variance_gadt env check rloc decl) tll with | vari :: rem -> let varl = List.fold_left (List.map2 Variance.union) vari rem in @@ -901,8 +955,10 @@ let check_duplicates sdecl_list = let name' = Hashtbl.find constrs pcd.pcd_name.txt in Location.prerr_warning pcd.pcd_loc (Warnings.Duplicate_definitions - ("constructor", pcd.pcd_name.txt, name', sdecl.ptype_name.txt)) - with Not_found -> Hashtbl.add constrs pcd.pcd_name.txt sdecl.ptype_name.txt) + ("constructor", pcd.pcd_name.txt, name', + sdecl.ptype_name.txt)) + with Not_found -> + Hashtbl.add constrs pcd.pcd_name.txt sdecl.ptype_name.txt) cl | Ptype_record fl -> List.iter @@ -940,8 +996,10 @@ let transl_type_decl env sdecl_list = let sdecl_list = List.map (fun sdecl -> - let ptype_name = mkloc (sdecl.ptype_name.txt ^"#row") sdecl.ptype_name.loc in - {sdecl with ptype_name; ptype_kind = Ptype_abstract; ptype_manifest = None}) + let ptype_name = + mkloc (sdecl.ptype_name.txt ^"#row") sdecl.ptype_name.loc in + {sdecl with + ptype_name; ptype_kind = Ptype_abstract; ptype_manifest = None}) fixed_types @ sdecl_list in @@ -977,7 +1035,7 @@ let transl_type_decl env sdecl_list = match !current_slot with | Some slot -> slot := (name, td) :: !slot | None -> - List.iter (fun (name, d) -> Env.mark_type_used name d) + List.iter (fun (name, d) -> Env.mark_type_used env name d) (get_ref slot); old_callback () ); @@ -1011,9 +1069,16 @@ let transl_type_decl env sdecl_list = id_list sdecl_list in List.iter (fun (id, decl) -> - check_well_founded newenv (List.assoc id id_loc_list) (Path.Pident id) decl) + check_well_founded_manifest newenv (List.assoc id id_loc_list) + (Path.Pident id) decl) decls; - List.iter (check_abbrev_recursion newenv id_loc_list) tdecls; + let to_check = + function Path.Pident id -> List.mem_assoc id id_loc_list | _ -> false in + List.iter (fun (id, decl) -> + check_well_founded_decl newenv (List.assoc id id_loc_list) (Path.Pident id) + decl to_check) + decls; + List.iter (check_abbrev_recursion newenv id_loc_list to_check) tdecls; (* Check that all type variable are closed *) List.iter2 (fun sdecl tdecl -> @@ -1062,7 +1127,7 @@ let transl_extension_constructor env check_open type_path type_params match sext.pext_kind with Pext_decl(sargs, sret_type) -> let targs, tret_type, args, ret_type = - make_constructor env type_path typext_params sext.pext_name.txt + make_constructor sext.pext_loc env type_path typext_params sext.pext_name.txt sargs sret_type in None, args, ret_type, Text_decl(targs, tret_type) @@ -1240,7 +1305,8 @@ let transl_type_extension check_open env loc styext = List.iter (fun ext -> match Ctype.closed_extension_constructor ext.ext_type with - Some ty -> raise(Error(ext.ext_loc, Unbound_type_var_ext(ty, ext.ext_type))) + Some ty -> + raise(Error(ext.ext_loc, Unbound_type_var_ext(ty, ext.ext_type))) | None -> ()) constructors; (* Check variances are correct *) @@ -1326,7 +1392,7 @@ let transl_value_decl env loc valdecl = (* Translate a "with" constraint -- much simplified version of transl_type_decl. *) let transl_with_constraint env id row_path orig_decl sdecl = - Env.mark_type_used (Ident.name id) orig_decl; + Env.mark_type_used env (Ident.name id) orig_decl; reset_type_variables(); Ctype.begin_def(); let tparams = make_params env sdecl.ptype_params in @@ -1437,9 +1503,10 @@ let approx_type_decl env sdecl_list = let check_recmod_typedecl env loc recmod_ids path decl = (* recmod_ids is the list of recursively-defined module idents. (path, decl) is the type declaration to be checked. *) - check_well_founded env loc path decl; - check_recursion env loc path decl - (fun path -> List.exists (fun id -> Path.isfree id path) recmod_ids) + let to_check path = + List.exists (fun id -> Path.isfree id path) recmod_ids in + check_well_founded_decl env loc path decl to_check; + check_recursion env loc path decl to_check (**** Error report ****) @@ -1500,6 +1567,10 @@ let report_error ppf = function fprintf ppf "Two labels are named %s" s | Recursive_abbrev s -> fprintf ppf "The type abbreviation %s is cyclic" s + | Cycle_in_def (s, ty) -> + Printtyp.reset_and_mark_loops ty; + fprintf ppf "@[<v>The definition of %s contains a cycle:@ %a@]" + s Printtyp.type_expr ty | Definition_mismatch (ty, errs) -> Printtyp.reset_and_mark_loops ty; fprintf ppf "@[<v>@[<hov>%s@ %s@;<1 2>%a@]%a@]" diff --git a/typing/typedecl.mli b/typing/typedecl.mli index bb3e3ea583..452674958b 100644 --- a/typing/typedecl.mli +++ b/typing/typedecl.mli @@ -62,6 +62,7 @@ type error = | Too_many_constructors | Duplicate_label of string | Recursive_abbrev of string + | Cycle_in_def of string * type_expr | Definition_mismatch of type_expr * Includecore.type_mismatch list | Constraint_failed of type_expr * type_expr | Inconsistent_constraint of Env.t * (type_expr * type_expr) list diff --git a/typing/typemod.ml b/typing/typemod.ml index bcd1e006b2..61295f4d78 100644 --- a/typing/typemod.ml +++ b/typing/typemod.ml @@ -208,21 +208,21 @@ let merge_constraint initial_env loc sg constr = real_id := Some id; (Pident id, lid, Twith_typesubst tdecl), make_next_first rs rem - | (Sig_module(id, md, rs) :: rem, [s], Pwith_module (_, lid)) + | (Sig_module(id, md, rs) :: rem, [s], Pwith_module (_, lid')) when Ident.name id = s -> - let path, md' = Typetexp.find_module initial_env loc lid.txt in + let path, md' = Typetexp.find_module initial_env loc lid'.txt in let md'' = {md' with md_type = Mtype.remove_aliases env md'.md_type} in let newmd = Mtype.strengthen_decl env md'' path in ignore(Includemod.modtypes env newmd.md_type md.md_type); - (Pident id, lid, Twith_module (path, lid)), + (Pident id, lid, Twith_module (path, lid')), Sig_module(id, newmd, rs) :: rem - | (Sig_module(id, md, rs) :: rem, [s], Pwith_modsubst (_, lid)) + | (Sig_module(id, md, rs) :: rem, [s], Pwith_modsubst (_, lid')) when Ident.name id = s -> - let path, md' = Typetexp.find_module initial_env loc lid.txt in + let path, md' = Typetexp.find_module initial_env loc lid'.txt in let newmd = Mtype.strengthen_decl env md' path in ignore(Includemod.modtypes env newmd.md_type md.md_type); real_id := Some id; - (Pident id, lid, Twith_modsubst (path, lid)), + (Pident id, lid, Twith_modsubst (path, lid')), make_next_first rs rem | (Sig_module(id, md, rs) :: rem, s :: namelist, _) when Ident.name id = s -> @@ -473,6 +473,11 @@ let rec remove_duplicates val_ids ext_ids = function | Sig_value (id, _) :: rem when List.exists (Ident.equal id) val_ids -> remove_duplicates val_ids ext_ids rem + | Sig_typext (id, decl, Text_first) :: Sig_typext (id2, ext2, Text_next) :: rem + when List.exists (Ident.equal id) ext_ids && Subst.sub_ids_ext decl = [] -> + (* #6510 *) + remove_duplicates val_ids ext_ids + (Sig_typext (id2, ext2, Text_first) :: rem) | Sig_typext (id, decl, _) :: rem when List.exists (Ident.equal id) ext_ids && Subst.sub_ids_ext decl = [] -> remove_duplicates val_ids ext_ids rem @@ -542,6 +547,7 @@ let rec transl_modtype env smty = let ty_arg = Misc.may_map (fun m -> m.mty_type) arg in let (id, newenv) = Env.enter_module ~arg:true param.txt (Btype.default_mty ty_arg) env in + Ctype.init_def(Ident.current_time()); (* PR#6513 *) let res = transl_modtype newenv sres in mkmty (Tmty_functor (id, param, arg, res)) (Mty_functor(id, ty_arg, res.mty_type)) env loc @@ -549,15 +555,15 @@ let rec transl_modtype env smty = | Pmty_with(sbody, constraints) -> let body = transl_modtype env sbody in let init_sg = extract_sig env sbody.pmty_loc body.mty_type in - let (tcstrs, final_sg) = + let (rev_tcstrs, final_sg) = List.fold_left - (fun (tcstrs,sg) sdecl -> + (fun (rev_tcstrs,sg) sdecl -> let (tcstr, sg) = merge_constraint env smty.pmty_loc sg sdecl in - (tcstr :: tcstrs, sg) + (tcstr :: rev_tcstrs, sg) ) ([],init_sg) constraints in - mkmty (Tmty_with ( body, tcstrs)) + mkmty (Tmty_with ( body, List.rev rev_tcstrs)) (Mtype.freshen (Mty_signature final_sg)) env loc smty.pmty_attributes | Pmty_typeof smod -> @@ -841,6 +847,29 @@ and transl_recmodule_modtypes loc env sdecls = in (dcl2, env2) +(* Simplify multiple specifications of a value or an extension in a signature. + (Other signature components, e.g. types, modules, etc, are checked for + name uniqueness.) If multiple specifications with the same name, + keep only the last (rightmost) one. *) + +let simplify_signature sg = + let rec simplif val_names ext_names res = function + [] -> res + | (Sig_value(id, descr) as component) :: sg -> + let name = Ident.name id in + simplif (StringSet.add name val_names) ext_names + (if StringSet.mem name val_names then res else component :: res) + sg + | (Sig_typext(id, ext, es) as component) :: sg -> + let name = Ident.name id in + simplif val_names (StringSet.add name ext_names) + (if StringSet.mem name ext_names then res else component :: res) + sg + | component :: sg -> + simplif val_names ext_names (component :: res) sg + in + simplif StringSet.empty StringSet.empty [] (List.rev sg) + (* Try to convert a module expression to a module path. *) exception Not_a_path @@ -1093,11 +1122,17 @@ let rec type_module ?(alias=false) sttn funct_body anchor env smod = | Pmod_structure sstr -> let (str, sg, finalenv) = type_structure funct_body anchor env sstr smod.pmod_loc in - rm { mod_desc = Tmod_structure str; - mod_type = Mty_signature sg; - mod_env = env; - mod_attributes = smod.pmod_attributes; - mod_loc = smod.pmod_loc } + let md = + rm { mod_desc = Tmod_structure str; + mod_type = Mty_signature sg; + mod_env = env; + mod_attributes = smod.pmod_attributes; + mod_loc = smod.pmod_loc } + in + let sg' = simplify_signature sg in + if List.length sg' = List.length sg then md else + wrap_constraint (Env.implicit_coercion env) md (Mty_signature sg') + Tmodtype_implicit | Pmod_functor(name, smty, sbody) -> let mty = may_map (transl_modtype env) smty in let ty_arg = may_map (fun m -> m.mty_type) mty in @@ -1323,7 +1358,16 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope = decls sbind in let newenv = (* allow aliasing recursive modules from outside *) List.fold_left - (fun env md -> Env.add_module md.md_id md.md_type.mty_type env) + (fun env md -> + let mdecl = + { + md_type = md.md_type.mty_type; + md_attributes = md.md_attributes; + md_loc = md.md_loc; + } + in + Env.add_module_declaration md.md_id mdecl env + ) env decls in let bindings2 = @@ -1498,26 +1542,35 @@ let rec simplify_modtype mty = | Mty_signature sg -> Mty_signature(simplify_signature sg) and simplify_signature sg = - let rec simplif val_names ext_names res = function - [] -> res - | (Sig_value(id, descr) as component) :: sg -> - let name = Ident.name id in - simplif (StringSet.add name val_names) ext_names - (if StringSet.mem name val_names then res else component :: res) - sg - | (Sig_typext(id, ext, es) as component) :: sg -> - let name = Ident.name id in - simplif val_names (StringSet.add name ext_names) - (if StringSet.mem name ext_names && Subst.sub_ids_ext ext = [] - then res else component :: res) - sg - | Sig_module(id, md, rs) :: sg -> - let md = {md with md_type = simplify_modtype md.md_type} in - simplif val_names ext_names (Sig_module(id, md, rs) :: res) sg - | component :: sg -> - simplif val_names ext_names (component :: res) sg + let rec aux = function + | [] -> [], StringSet.empty, StringSet.empty + | (Sig_value(id, descr) as component) :: sg -> + let (sg, val_names, ext_names) as k = aux sg in + let name = Ident.name id in + if StringSet.mem name val_names then k + else (component :: sg, StringSet.add name val_names, ext_names) + | (Sig_typext(id, ext, es) as component) :: sg -> + let (sg, val_names, ext_names) as k = aux sg in + let name = Ident.name id in + if StringSet.mem name ext_names && Subst.sub_ids_ext ext = [] then + (* #6510 *) + match es, sg with + | Text_first, Sig_typext(id2, ext2, Text_next) :: rest -> + (Sig_typext(id2, ext2, Text_first) :: rest, + val_names, ext_names) + | _ -> k + else + (component :: sg, val_names, StringSet.add name ext_names) + | Sig_module(id, md, rs) :: sg -> + let (sg, val_names, ext_names) = aux sg in + let md = {md with md_type = simplify_modtype md.md_type} in + (Sig_module(id, md, rs) :: sg, val_names, ext_names) + | component :: sg -> + let (sg, val_names, ext_names) = aux sg in + (component :: sg, val_names, ext_names) in - simplif StringSet.empty StringSet.empty [] (List.rev sg) + let (sg, _, _) = aux sg in + sg (* Extract the module type of a module expression *) @@ -1535,8 +1588,6 @@ let type_module_type_of env smod = let mty = tmty.mod_type in (* PR#6307: expand aliases at root and submodules *) let mty = Mtype.remove_aliases env mty in - (* PR#5037: clean up inferred signature to remove duplicate specs *) - let mty = simplify_modtype mty in (* PR#5036: must not contain non-generalized type variables *) if not (closed_modtype mty) then raise(Error(smod.pmod_loc, env, Non_generalizable_module mty)); diff --git a/typing/types.ml b/typing/types.ml index 2b3f26ce6f..78fb4d2dbe 100644 --- a/typing/types.ml +++ b/typing/types.ml @@ -126,7 +126,7 @@ and constructor_tag = Cstr_constant of int (* Constant constructor (an int) *) | Cstr_block of int (* Regular constructor (a block) *) | Cstr_extension of Path.t * bool (* Extension constructor - true if a constant false if a block *) + true if a constant false if a block*) (* Record label descriptions *) diff --git a/typing/types.mli b/typing/types.mli index 9fc3d0dc14..a67837c8d1 100644 --- a/typing/types.mli +++ b/typing/types.mli @@ -123,7 +123,7 @@ and constructor_tag = Cstr_constant of int (* Constant constructor (an int) *) | Cstr_block of int (* Regular constructor (a block) *) | Cstr_extension of Path.t * bool (* Extension constructor - true if a constant false if a block *) + true if a constant false if a block*) (* Record label descriptions *) diff --git a/typing/typetexp.ml b/typing/typetexp.ml index 31d4a44f1b..523d435bca 100644 --- a/typing/typetexp.ml +++ b/typing/typetexp.ml @@ -107,6 +107,14 @@ let check_deprecated loc attrs s = attrs let emit_external_warnings = + (* Note: this is run as a preliminary pass when type-checking an + interface or implementation. This allows to cover all kinds of + attributes, but the drawback is that it doesn't take local + configuration of warnings (with '@@warning'/'@@warnerror' + attributes) into account. We should rather check for + 'ppwarning' attributes during the actual type-checking, making + sure to cover all contexts (easier and more ugly alternative: + duplicate here the logic which control warnings locally). *) let open Ast_mapper in { default_mapper with @@ -127,21 +135,18 @@ let emit_external_warnings = let warning_scope = ref [] let warning_enter_scope () = - warning_scope := ref None :: !warning_scope + warning_scope := (Warnings.backup ()) :: !warning_scope let warning_leave_scope () = match !warning_scope with | [] -> assert false | hd :: tl -> - may Warnings.restore !hd; + Warnings.restore hd; warning_scope := tl let warning_attribute attrs = - let prev_warnings = List.hd !warning_scope in let process loc txt errflag payload = match string_of_payload payload with | Some s -> - if !prev_warnings = None then - prev_warnings := Some (Warnings.backup ()); begin try Warnings.parse_options errflag s with Arg.Bad _ -> Location.prerr_warning loc @@ -419,6 +424,8 @@ let rec transl_type env policy styp = let ty = newty (Tarrow(l, cty1.ctyp_type, cty2.ctyp_type, Cok)) in ctyp (Ttyp_arrow (l, cty1, cty2)) ty | Ptyp_tuple stl -> + if List.length stl < 2 then + Syntaxerr.ill_formed_ast loc "Tuples must have at least 2 components."; let ctys = List.map (transl_type env policy) stl in let ty = newty (Ttuple (List.map (fun ctyp -> ctyp.ctyp_type) ctys)) in ctyp (Ttyp_tuple ctys) ty diff --git a/utils/clflags.ml b/utils/clflags.ml index f582a46559..57834ccf91 100644 --- a/utils/clflags.ml +++ b/utils/clflags.ml @@ -50,6 +50,7 @@ and principal = ref false (* -principal *) and real_paths = ref true (* -short-paths *) and recursive_types = ref false (* -rectypes *) and strict_sequence = ref false (* -strict-sequence *) +and strict_formats = ref false (* -strict-formats *) and applicative_functors = ref true (* -no-app-funct *) and make_runtime = ref false (* -make-runtime *) and gprofile = ref false (* -p *) @@ -71,6 +72,7 @@ and dump_instr = ref false (* -dinstr *) let keep_asm_file = ref false (* -S *) let optimize_for_speed = ref true (* -compact *) +and opaque = ref false (* -opaque *) and dump_cmm = ref false (* -dcmm *) let dump_selection = ref false (* -dsel *) @@ -86,7 +88,6 @@ let dump_scheduling = ref false (* -dscheduling *) let dump_linear = ref false (* -dlinear *) let keep_startup_file = ref false (* -dstartup *) let dump_combine = ref false (* -dcombine *) - let native_code = ref false (* set to true under ocamlopt *) let inline_threshold = ref 10 let force_slash = ref false (* for ocamldep *) diff --git a/utils/clflags.mli b/utils/clflags.mli index 5474157c37..7e51cf33db 100644 --- a/utils/clflags.mli +++ b/utils/clflags.mli @@ -47,6 +47,7 @@ val principal : bool ref val real_paths : bool ref val recursive_types : bool ref val strict_sequence : bool ref +val strict_formats : bool ref val applicative_functors : bool ref val make_runtime : bool ref val gprofile : bool ref @@ -92,3 +93,4 @@ val runtime_variant : string ref val force_slash : bool ref val keep_locs : bool ref val unsafe_string : bool ref +val opaque : bool ref diff --git a/utils/consistbl.ml b/utils/consistbl.ml index 6adaf41122..37f6a2b1e6 100644 --- a/utils/consistbl.ml +++ b/utils/consistbl.ml @@ -41,12 +41,9 @@ let set tbl name crc source = Hashtbl.add tbl name (crc, source) let source tbl name = snd (Hashtbl.find tbl name) let extract l tbl = + let l = List.sort_uniq String.compare l in List.fold_left (fun assc name -> - try - ignore (List.assoc name assc); - assc - with Not_found -> try let (crc, _) = Hashtbl.find tbl name in (name, Some crc) :: assc diff --git a/utils/warnings.ml b/utils/warnings.ml index 2dc26a3504..103789c4ed 100644 --- a/utils/warnings.ml +++ b/utils/warnings.ml @@ -162,21 +162,27 @@ let letter = function | _ -> assert false ;; -let active = Array.create (last_warning_number + 1) true;; -let error = Array.create (last_warning_number + 1) false;; +type state = + { + active: bool array; + error: bool array; + } -type state = bool array * bool array -let backup () = (Array.copy active, Array.copy error) -let restore (a, e) = - assert(Array.length a = Array.length active); - assert(Array.length e = Array.length error); - Array.blit a 0 active 0 (Array.length active); - Array.blit e 0 error 0 (Array.length error) +let current = + ref + { + active = Array.make (last_warning_number + 1) true; + error = Array.make (last_warning_number + 1) false; + } -let is_active x = active.(number x);; -let is_error x = error.(number x);; +let backup () = !current -let parse_opt flags s = +let restore x = current := x + +let is_active x = (!current).active.(number x);; +let is_error x = (!current).error.(number x);; + +let parse_opt error active flags s = let set i = flags.(i) <- true in let clear i = flags.(i) <- false in let set_all i = active.(i) <- true; error.(i) <- true in @@ -227,7 +233,11 @@ let parse_opt flags s = loop 0 ;; -let parse_options errflag s = parse_opt (if errflag then error else active) s;; +let parse_options errflag s = + let error = Array.copy (!current).error in + let active = Array.copy (!current).active in + parse_opt error active (if errflag then error else active) s; + current := {error; active} (* If you change these, don't forget to change them in man/ocamlc.m *) let defaults_w = "+a-4-6-7-9-27-29-32..39-41..42-44-45-48";; @@ -239,7 +249,7 @@ let () = parse_options true defaults_warn_error;; let message = function | Comment_start -> "this is the start of a comment." | Comment_not_end -> "this is not the end of a comment." - | Deprecated s -> "deprecated feature: " ^ s + | Deprecated s -> "deprecated: " ^ s | Fragile_match "" -> "this pattern-matching is fragile." | Fragile_match s -> @@ -322,7 +332,8 @@ let message = function "constructor " ^ s ^ " is never used to build values.\n\ Its type is exported as a private type." - | Unused_extension (s, false, false) -> "unused extension constructor " ^ s ^ "." + | Unused_extension (s, false, false) -> + "unused extension constructor " ^ s ^ "." | Unused_extension (s, true, _) -> "extension constructor " ^ s ^ " is never used to build values.\n\ @@ -384,15 +395,14 @@ let print ppf w = for i = 0 to String.length msg - 1 do if msg.[i] = '\n' then incr newlines; done; - let (out, flush, newline, space) = - Format.pp_get_all_formatter_output_functions ppf () - in - let countnewline x = incr newlines; newline x in - Format.pp_set_all_formatter_output_functions ppf out flush countnewline space; + let out_functions = Format.pp_get_formatter_out_functions ppf () in + let countnewline x = incr newlines; out_functions.Format.out_newline x in + Format.pp_set_formatter_out_functions ppf + {out_functions with Format.out_newline = countnewline}; Format.fprintf ppf "%d: %s" num msg; Format.pp_print_flush ppf (); - Format.pp_set_all_formatter_output_functions ppf out flush newline space; - if error.(num) then incr nerrors; + Format.pp_set_formatter_out_functions ppf out_functions; + if (!current).error.(num) then incr nerrors; !newlines ;; |