diff options
| author | Luc Maranget <luc.maranget@inria.fr> | 2014-03-13 15:03:16 +0000 |
|---|---|---|
| committer | Luc Maranget <luc.maranget@inria.fr> | 2014-03-13 15:03:16 +0000 |
| commit | 1338d73c180d22cd2fd2abc5b46554a56f66b1f5 (patch) | |
| tree | 1d7171e373a49abdbac5bc790f896aadbca27718 | |
| parent | 18e6a3781be059367bfff403aa8a41e9dc200844 (diff) | |
| download | ocaml-jo401.tar.gz | |
Merge jo401 w.r.t ocaml/4.01 from 13776 to 14115jo401
Plus ld.conf changes
git-svn-id: http://caml.inria.fr/svn/ocaml/branches/jo401@14458 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02
218 files changed, 3359 insertions, 1146 deletions
@@ -1,5 +1,5 @@ -Next version ------------- +OCaml 4.01.0: +------------- (Changes that can break existing programs are marked with a "*") @@ -7,41 +7,73 @@ Other libraries: - Labltk: updated to Tcl/Tk 8.6. Type system: +- PR#5759: use well-disciplined type information propagation to + disambiguate label and constructor names + (Jacques Garrigue, Alain Frisch and Leo P. White) * Propagate type information towards pattern-matching, even in the presence of polymorphic variants (discarding only information about possibly-present constructors). As a result, matching against absent constructors is no longer allowed for exact and fixed polymorphic variant types. + (Jacques Garrigue) * PR#6035: Reject multiple declarations of the same method or instance variable in an object + (Alain Frisch) Compilers: - PR#5861: raise an error when multiple private keywords are used in type declarations + (Hongbo Zhang) - PR#5634: parsetree rewriter (-ppx flag) + (Alain Frisch) - ocamldep now supports -absname + (Alain Frisch) - PR#5768: On "unbound identifier" errors, use spell-checking to suggest names present in the environment + (Gabriel Scherer) - ocamlc has a new option -dsource to visualize the parsetree + (Alain Frisch, Hongbo Zhang) - tools/eqparsetree compares two parsetree ignoring location + (Hongbo Zhang) - ocamlopt now uses clang as assembler on OS X if available, which enables CFI support for OS X. + (Benedikt Meurer) - Added a new -short-paths option, which attempts to use the shortest representation for type constructors inside types, taking open modules into account. This can make types much more readable if your code uses lots of functors. + (Jacques Garrigue) - PR#5986: added flag -compat-32 to ocamlc, ensuring that the generated bytecode executable can be loaded on 32-bit hosts. -- PR#5980: warning on open statements which shadow an existing identifier - (if it is actually used in the scope of the open) + (Xavier Leroy) +- PR#5980: warning on open statements which shadow an existing + identifier (if it is actually used in the scope of the open); new + open! syntax to silence it locally + (Alain Frisch, thanks to a report of Daniel Bünzli) * warning 3 is extended to warn about other deprecated features: - ISO-latin1 characters in identifiers - uses of the (&) and (or) operators instead of (&&) and (||) -- Experimental OCAMLCOMPPARAM for ocamlc and ocamlopt + (Damien Doligez) +- Experimental OCAMLPARAM for ocamlc and ocamlopt + (Fabrice Le Fessant) +- PR#5571: incorrect ordinal number in error message + (Alain Frisch, report by John Carr) +- PR#6073: add signature to Tstr_include + (patch by Leo P. White) Standard library: +- PR#5899: expose a way to inspect the current call stack, + Printexc.get_callstack + (Gabriel Scherer, Jacques-Henri Jourdan, Alain Frisch) - PR#5986: new flag Marshal.Compat_32 for the serialization functions (Marshal.to_*), forcing the output to be readable on 32-bit hosts. -- Add optimized composition operators |> and @@ in Pervasives + (Xavier Leroy) +- infix application operators |> and @@ in Pervasives + (Fabrice Le Fessant) + +Other libraries: +- PR#5568: add O_CLOEXEC flag to Unix.openfile, so that the returned + file descriptor is created in close-on-exec mode + (Xavier Leroy) Runtime system: * PR#6019: more efficient implementation of caml_modify() and caml_initialize(). @@ -49,119 +81,350 @@ Runtime system: the destination pointer of caml_modify() must point within the minor or major heaps, and the destination pointer of caml_initialize() must point within the major heap. + (Xavier Leroy, from an experiment by Brian Nigito, with feedback + from Yaron Minsky and Gerd Stolpmann) + +Internals: +- Moved debugger/envaux.ml to typing/envaux.ml to publish env_of_only_summary + as part of compilerlibs, to be used on bin-annot files. + (Fabrice Le Fessant) +- The test suite can now be run without installing OCaml first. + (Damien Doligez) Bug fixes: +- PR#3236: Document the fact that queues are not thread-safe + (Damien Doligez) +- PR#3468: (part 1) Sys_error documentation + (Damien Doligez) - PR#3679: Warning display problems + (Fabrice Le Fessant) - PR#3963: Graphics.wait_next_event in Win32 hangs if window closed + (Damien Doligez) +- PR#4079: Queue.copy is now tail-recursive + (patch by Christophe Papazian) +- PR#4138: Documentation for Unix.mkdir + (Damien Doligez) +- PR#4469: emacs mode: caml-set-compile-command is annoying with ocamlbuild + (Daniel Bünzli) +- PR#4485: Graphics: Keyboard events incorrectly delivered in native code + (Damien Doligez, report by Sharvil Nanavati) +- PR#4502: ocamlbuild now reliably excludes the build-dir from hygiene check + (Gabriel Scherer, report by Romain Bardou) - PR#4762: ?? is not used at all, but registered as a lexer token + (Alain Frisch) +- PR#4788: wrong error message when executable file is not found for backtrace + (Damien Doligez, report by Claudio Sacerdoti Coen) +- PR#4812: otherlibs/unix: add extern int code_of_unix_error (value error); + (Goswin von Berdelow) - PR#4887: input_char after close_in crashes ocaml (msvc runtime) + (Alain Frisch and Christoph Bauer, report by ygrek) - PR#4994: ocaml-mode doesn't work with xemacs21 + (Damien Doligez, report by Stéphane Glondu) - PR#5098: creating module values may lead to memory leaks + (Alain Frisch, report by Milan Stanojević) - PR#5102: ocamlbuild fails when using an unbound variable in rule dependency + (Xavier Clerc, report by Daniel Bünzli) * PR#5119: camlp4 now raises a specific exception when 'DELETE_RULE' fails, rather than raising 'Not_found' + (ygrek) - PR#5121: %( %) in Format module seems to be broken + (Pierre Weis, first patch by Valentin Gatien-Baron, report by Khoo Yit Phang) +- PR#5178: document in INSTALL how to build a 32-bit version under Linux x86-64 + (Benjamin Monate) - PR#5212: Improve ocamlbuild error messages of _tags parser + (ygrek) - PR#5240: register exception printers for Unix.Unix_error and Dynlink.Error + (Jérémie Dimino) - PR#5300: ocamlbuild: verbose parameter should implicitly set classic display + (Xavier Clerc, report by Robert Jakob) - PR#5327: (Windows) Unix.select blocks if same socket listed in first and third arguments + (David Allsopp, displaying impressive MSDN skills) - PR#5343: ocaml -rectypes is unsound wrt module subtyping (was still unsound) + (Jacques Garrigue) +- PR#5350: missing return code checks in the runtime system + (Xavier Leroy) - PR#5468: ocamlbuild should preserve order of parametric tags + (Wojciech Meyer, report by Dario Texeira) - PR#5551: Avoid repeated lookups for missing cmi files -- PR#5552: try to use camlp4.opt if it's possible + (Alain Frisch) +- PR#5552: unrecognized gcc option -no-cpp-precomp + (Damien Doligez, report by Markus Mottl) - PR#5580: missed opportunities for constant propagation + (Xavier Leroy and John Carr) - PR#5611: avoid clashes betwen .cmo files and output files during linking + (Wojciech Meyer) - PR#5662: typo in md5.c + (Olivier Andrieu) - PR#5673: type equality in a polymorphic field + (Jacques Garrigue, report by Jean-Louis Giavitto) +- PR#5674: Methods call are 2 times slower with 4.00 than with 3.12 + (Jacques Garrigue, Gabriel Scherer, report by Jean-Louis Giavitto) +- PR#5694: Exception raised by type checker + (Jacques Garrigue, report by Markus Mottl) - PR#5695: remove warnings on sparc code emitter + (Fabrice Le Fessant) - PR#5697: better location for warnings on statement expressions + (Dan Bensen) - PR#5698: remove harcoded limit of 200000 labels in emitaux.ml + (Fabrice Le Fessant, report by Marcin Sawicki) +- PR#5702: bytecomp/bytelibrarian lib_sharedobjs was defined but never used + (Hongbo Zhang, Fabrice Le Fessant) - PR#5708: catch Failure"int_of_string" in ocamldebug + (Fabrice Le Fessant, report by user 'schommer') +- PR#5712: (9) new option -bin-annot is not documented + (Damien Doligez, report by Hendrik Tews) - PR#5731: instruction scheduling forgot to account for destroyed registers + (Xavier Leroy, Benedikt Meurer, reported by Jeffrey Scofield) - PR#5734: improved Win32 implementation of Unix.gettimeofday + (David Allsopp) - PR#5735: %apply and %revapply not first class citizens + (Fabrice Le Fessant, reported by Jun Furuse) - PR#5738: first class module patterns not handled by ocamldep + (Fabrice Le Fessant, Jacques Garrigue, reported by Hongbo Zhang) +- PR#5739: Printf.printf "%F" (-.nan) returns -nan + (Xavier Leroy, David Allsopp, reported by Samuel Mimram) +- PR#5741: make pprintast.ml in compiler_libs + (Alain Frisch, Hongbo Zhang) - PR#5747: 'unused open' warning not given when compiling with -annot + (Alain Frisch, reported by Valentin Gatien-Baron) - PR#5752: missing dependencies at byte-code link with mlpack -- PR#5758: Compiler bug when matching on floats + (Wojciech Meyer, Nicholas Lucaroni) - PR#5763: ocamlbuild does not give correct flags when running menhir + (Gabriel Scherer, reported by Philippe Veber) +- PR#5765: ocamllex doesn't preserve line directives + (Damien Doligez, reported by Martin Jambon) +- PR#5770: Syntax error messages involving unclosed parens are sometimes + incorrect + (Michel Mauny) - PR#5772: problem with marshaling of mutually-recursive functions + (Jacques-Henri Jourdan, reported by Cédric Pasteur) - PR#5775: several bug fixes for tools/pprintast.ml + (Hongbo Zhang) - PR#5784: -dclambda option is ignored + (Pierre Chambart) - PR#5785: misbehaviour with abstracted structural type used as GADT index + (Jacques Garrigue, report by Jeremy Yallop) - PR#5787: Bad behavior of 'Unused ...' warnings in the toplevel -- PR#5770: Syntax error messages involving unclosed parens are sometimes - incorrect + (Alain Frisch) - PR#5793: integer marshalling is inconsistent between architectures + (Xavier Clerc, report by Pierre-Marie Pédrot) - PR#5798: add ARM VFPv2 support for Raspbian (ocamlopt) + (Jeffrey Scofield and Anil Madhavapeddy, patch review by Benedikt Meurer) +- PR#5802: Avoiding "let" as a value name + (Jacques Garrigue, report by Tiphaine Turpin) - PR#5805: Assert failure with warning 34 on pre-processed file + (Alain Frisch, report by Tiphaine Turpin) - PR#5806: ensure that backtrace tests are always run (testsuite) + (Xavier Clerc, report by user 'michi') +- PR#5809: Generating .cmt files takes a long time, in case of type error + (Alain Frisch) - PR#5810: error in switch printing when using -dclambda + (Pierre Chambart) +- PR#5811: Untypeast produces singleton tuples for constructor patterns + with only one argument + (Tiphaine Turpin) - PR#5813: GC not called when unmarshaling repeatedly in a tight loop (ocamlopt) + (Xavier Leroy, report by David Waern) +- PR#5814: read_cmt -annot does not report internal references + (Alain Frisch) +- PR#5815: Multiple exceptions in signatures gives an error + (Leo P. White) +- PR#5816: read_cmt -annot does not work for partial .cmt files + (Alain Frisch) - PR#5819: segfault when using [with] on large recursive record (ocamlopt) + (Xavier Leroy, Damien Doligez) - PR#5821: Wrong record field is reported as duplicate + (Alain Frisch, report by Martin Jambon) - PR#5824: Generate more efficient code for immediate right shifts. + (Pierre Chambart, review by Xavier Leroy) - PR#5825: Add a toplevel primitive to use source file wrapped with the coresponding module + (Grégoire Henry, Wojciech Meyer, caml-list discussion) +- PR#5833: README.win32 can leave the wrong flexlink in the path + (Damien Doligez, report by William Smith) - PR#5835: nonoptional labeled arguments can be passed with '?' + (Jacques Garrigue, report by Elnatan Reisner) - PR#5840: improved documentation for 'Unix.lseek' + (Xavier Clerc, report by Matej KoÅ¡Ãk) +- PR#5848: Assertion failure in type checker + (Jacques Garrigue, Alain Frisch, report by David Waern) - PR#5858: Assert failure during typing of class + (Jacques Garrigue, report by Julien Signoles) - PR#5865: assert failure when reporting undefined field label + (Jacques Garrigue, report by Anil Madhavapeddy) +- PR#5872: Performance: Buffer.add_char is not inlined + (Gerd Stolpmann, Damien Doligez) +- PR#5876: Uncaught exception with a typing error + (Alain Frisch, Gabriel Scherer, report by Julien Moutinho) +- PR#5877: multiple "open" can become expensive in memory + (Fabrice Le Fessant and Alain Frisch) - PR#5880: 'Genlex.make_lexer' documention mentions the wrong exception + (Xavier Clerc, report by Virgile Prevosto) - PR#5885: Incorrect rule for compiling C stubs when shared libraries are not supported. + (Jérôme Vouillon) - PR#5891: ocamlbuild: support rectypes tag for mlpack + (Khoo Yit Phang) - PR#5892: GADT exhaustiveness check is broken + (Jacques Garrigue and Leo P. White) - PR#5906: GADT exhaustiveness check is still broken + (Jacques Garrigue, report by Sébastien Briais) - PR#5907: Undetected cycle during typecheck causes exceptions + (Jacques Garrigue, report by Pascal Zimmer) - PR#5910: Fix code generation bug for "mod 1" on ARM. + (Benedikt Meurer, report by user 'jteg68') - PR#5911: Signature substitutions fail in submodules -- PR#5920, PR#2957: linking failure for big bytecodes on 32bit architectures + (Jacques Garrigue, report by Markus Mottl) +- PR#5912: add configure option -no-cfi (for OSX 10.6.x with XCode 4.0.2) + (Damien Doligez against XCode versions, report by Thomas Gazagnaire) +- PR#5914: Functor breaks with an equivalent argument signature + (Jacques Garrigue, report by Markus Mottl and Grégoire Henry) +- PR#5920, PR#5957: linking failure for big bytecodes on 32bit architectures + (Benoît Vaugon and Chet Murthy, report by Jun Furuse and Sebastien Mondet) - PR#5928: Missing space between words in manual page for ocamlmktop + (Damien Doligez, report by Matej KoÅ¡Ãk) - PR#5930: ocamldep leaks temporary preprocessing files + (Gabriel Scherer, report by Valentin Gatien-Baron) +- PR#5933: Linking is slow when there are functions with large arities + (Valentin Gatien-Baron, review by Gabriel Scherer) - PR#5934: integer shift by negative amount (in otherlibs/num) + (Xavier Leroy, report by John Regehr) - PR#5944: Bad typing performances of big variant type declaration + (Benoît Vaugon) +- PR#5945: Mix-up of Minor_heap_min and Minor_heap_max units + (Benoît Vaugon) - PR#5948: GADT with polymorphic variants bug + (Jacques Garrigue, report by Leo P. White) +- PR#5953: Unix.system does not handle EINTR + (Jérémie Dimino) - PR#5965: disallow auto-reference to a recursive module in its definition + (Alain Frisch, report by Arthur Windler via Gabriel Scherer) - PR#5973: Format module incorrectly parses format string + (Pierre Weis, report by Frédéric Bour) +- PR#5974: better documentation for Str.regexp + (Damien Doligez, report by william) - PR#5976: crash after recovering from two stack overflows (ocamlopt on MacOS X) + (Xavier Leroy, report by Pierre Boutillier) +- PR#5977: Build failure on raspberry pi: "input_value: integer too large" + (Alain Frisch, report by Sylvain Le Gall) - PR#5981: Incompatibility check assumes abstracted types are injective + (Jacques Garrigue, report by Jeremy Yallop) +- PR#5982: caml_leave_blocking section and errno corruption + (Jérémie Dimino) - PR#5985: Unexpected interaction between variance and GADTs + (Jacques Garrigue, Jeremy Yallop and Leo P. White and Gabriel Scherer) +- PR#5988: missing from the documentation: -impl is a valid flag for ocamlopt + (Damien Doligez, report by Vincent Bernardoff) - PR#5989: Assumed inequalities involving private rows + (Jacques Garrigue, report by Jeremy Yallop) +- PR#5992: Crash when pattern-matching lazy values modifies the scrutinee + (Luc Maranget, Leo P. White) - PR#5993: Variance of private type abbreviations not checked for modules + (Jacques Garrigue) - PR#5997: Non-compatibility assumed for concrete types with same constructor + (Jacques Garrigue, report by Gabriel Scherer) - PR#6004: Type information does not flow to "inherit" parameters + (Jacques Garrigue, report by Alain Frisch) - PR#6005: Type unsoundness with recursive modules + (Jacques Garrigue, report by Jérémie Dimino and Josh Berdine) - PR#6010: Big_int.extract_big_int gives wrong results on negative arguments + (Xavier Leroy, report by Drake Wilson via Stéphane Glondu) - PR#6024: Format syntax for printing @ is incompatible with 3.12.1 + (Damien Doligez, report by Boris Yakobowski) - PR#6001: Reduce the memory used by compiling Camlp4 + (Hongbo Zhang and Gabriel Scherer, report by Henri Gouraud) - PR#6031: Camomile problem with -with-frame-pointers + (Fabrice Le Fessant, report by Anil Madhavapeddy) - PR#6032: better Random.self_init under Windows + (Alain Frisch, Xavier Leroy) - PR#6033: Matching.inline_lazy_force needs eta-expansion (command-line flags) - -Internals: -- Moved debugger/envaux.ml to typing/envaux.ml to publish env_of_only_summary - as part of compilerlibs, to be used on bin-annot files. + (Pierre Chambart, Xavier Leroy and Luc Maranget, + regression report by Gabriel Scherer) +- PR#6046: testsuite picks up the wrong ocamlrun dlls + (Anil Madhavapeddy) +- PR#6056: Using 'match' prevents generalization of values + (Jacques Garrigue, report by Elnatan Reisner) +- PR#6058: 'ocamlbuild -use-ocamlfind -tag thread -package threads t.cma' fails + (Gabriel Scherer, report by Hezekiah M. Carty) +- PR#6060: ocamlbuild rules for -principal, -strict-sequence and -short-paths + (Anil Madhavapeddy) +- PR#6069: ocamldoc: lexing: empty token + (Maxence Guesdon, Grégoire Henry, report by ygrek) +- PR#6072: configure does not handle FreeBSD current (i.e. 10) correctly + (Damien Doligez, report by Prashanth Mundkur) +- PR#6074: Wrong error message for failing Condition.broadcast + (Markus Mottl) +- PR#6084: Define caml_modify and caml_initialize as weak symbols to help + with Netmulticore + (Xavier Leroy, Gerd Stolpmann) +- PR#6090: Module constraint + private type seems broken in ocaml 4.01.0 + (Jacques Garrigue, report by Jacques-Pascal Deplaix) +- PR#6109: Typos in ocamlbuild error messages + (Gabriel Kerneis) +- PR#6123: Assert failure when self escapes its class + (Jacques Garrigue, report by whitequark) +- PR#6158: Fatal error using GADTs + (Jacques Garrigue, report by Jeremy Yallop) +- PR#6163: Assert_failure using polymorphic variants in GADTs + (Jacques Garrigue, report by Leo P. White) +- PR#6164: segmentation fault on Num.power_num of 0/1 + (Fabrice Le Fessant, report by Johannes Kanig) Feature wishes: +- PR#5181: Merge common floating point constants in ocamlopt + (Benedikt Meurer) +- PR#5243: improve the ocamlbuild API documentation in signatures.mli + (Christophe Troestler) +- PR#5546: moving a function into an internal module slows down its use + (Alain Frisch, report by Fabrice Le Fessant) - PR#5597: add instruction trace option 't' to OCAMLRUNPARAM + (Anil Madhavapeddy, Wojciech Meyer) +- PR#5676: IPv6 support under Windows + (Jérôme Vouillon, review by Jonathan Protzenko) - PR#5721: configure -with-frame-pointers for Linux perf profiling + (Fabrice Le Fessant, test by Jérémie Dimino) +- PR#5722: toplevel: print full module path only for first record field + (Jacques Garrigue, report by ygrek) - PR#5762: Add primitives for fast access to bigarray dimensions -- PR#5795: Generate sqrtsd opcode instead of external call to sqrt on amd64 + (Pierre Chambart) - PR#5769: Allow propagation of Sys.big_endian in native code + (Pierre Chambart, stealth commit by Fabrice Le Fessant) - PR#5771: Add primitives for reading 2, 4, 8 bytes in strings and bigarrays + (Pierre Chambart) - PR#5774: Add bswap primitives for amd64 and arm + (Pierre Chambart, test by Alain Frisch) +- PR#5795: Generate sqrtsd opcode instead of external call to sqrt on amd64 + (Pierre Chambart) - PR#5827: provide a dynamic command line parsing mechanism + (Hongbo Zhang) +- PR#5832: patch to improve "wrong file naming" error messages + (William Smith) - PR#5864: Add a find operation to Set + (François Berenger) +- PR#5886: Small changes to compile for Android + (Jérôme Vouillon, review by Benedikt Meurer) +- PR#5902: -ppx based pre-processor executables accept arguments + (Alain Frisch, report by Wojciech Meyer) +- PR#5986: Protect against marshaling 64-bit integers in bytecode + (Xavier Leroy, report by Alain Frisch) +- PR#6049: support for OpenBSD/macppc platform + (Anil Madhavapeddy, review by Benedikt Meurer) +- PR#6059: add -output-obj rules for ocamlbuild + (Anil Madhavapeddy) Tools: - OCamlbuild now features a bin_annot tag to generate .cmt files. -- OCamlbuild now features a strict_sequence tag to trigger the strict-sequence - option. + (Jonathan Protzenko) +- OCamlbuild now features a strict_sequence tag to trigger the + strict-sequence option. + (Jonathan Protzenko) - OCamlbuild now picks the non-core tools like ocamlfind and menhir from PATH + (Wojciech Meyer) - PR#5884: Misc minor fixes and cleanup for emacs mode + (Stefan Monnier) - PR#6030: Improve performance of -annot + (Guillaume Melquiond, Alain Frisch) OCaml 4.00.1: @@ -358,8 +621,6 @@ Bug Fixes: - PR#5318: segfault on stack overflow when reading marshaled data - PR#5319: %r11 clobbered by Lswitch in Windows AMD64 native-code compilation - PR#5322: type abbreviations expanding to a universal type variable -- PR#5325: (Windows) blocked Unix.recv in one thread blocks Unix.send in - another thread - PR#5328: under Windows, Unix.select leaves sockets in non-blocking mode - PR#5330: thread tag with '.top' and '.inferred.mli' targets - PR#5331: ocamlmktop is not always a shell script @@ -9,12 +9,10 @@ CONTEXT the name 'INSTALL_OCAML'. Here we focus on differences with Objective Caml installation. - * They are the same as the ones of Objective Caml, * plus: the POSIX threads library 'phreads' is required. - INSTALLATION INSTRUCTIONS 1- Configure the system. From the top directory, do: @@ -47,6 +45,7 @@ Added options. The Objective Caml library is <dir>. No version check is performed. Use this option at your own risk. + 2- From the top directory, do: make world @@ -765,14 +765,6 @@ camlp4opt: # ./build/ocamlbuild-byte-only.sh #endif -#ocamlbuild.native: ocamlopt ocamlbuild-mixed-boot -# ./build/ocamlbuild-native-only.sh -#ocamlbuildlib.native: ocamlopt ocamlbuild-mixed-boot -# ./build/ocamlbuildlib-native-only.sh -# -#ocamlbuild-mixed-boot: ocamlc -# ./build/mixed-boot.sh -# touch ocamlbuild-mixed-boot ocamlbuild.byte: ocamlbuild.native: @@ -1,4 +1,4 @@ -4.01.0+dev17-2013-06-13 +4.01.0 # 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/asmlink.ml b/asmcomp/asmlink.ml index 01ae225978..371ca12361 100644 --- a/asmcomp/asmlink.ml +++ b/asmcomp/asmlink.ml @@ -318,7 +318,8 @@ let link ppf objfiles output_name = (fun (info, file_name, crc) -> check_consistency file_name info crc) units_tolink; Clflags.ccobjs := !Clflags.ccobjs @ !lib_ccobjs; - Clflags.all_ccopts := !lib_ccopts @ !Clflags.all_ccopts; (* put user's opts first *) + Clflags.all_ccopts := !lib_ccopts @ !Clflags.all_ccopts; + (* put user's opts first *) let startup = if !Clflags.keep_startup_file then output_name ^ ".startup" ^ ext_asm else Filename.temp_file "camlstartup" ext_asm in diff --git a/asmcomp/asmpackager.ml b/asmcomp/asmpackager.ml index 07de946861..1a4fe90274 100644 --- a/asmcomp/asmpackager.ml +++ b/asmcomp/asmpackager.ml @@ -189,8 +189,9 @@ open Format let report_error ppf = function Illegal_renaming(name, file, id) -> - fprintf ppf "Wrong file naming: %a@ contains the code for @ %s when %s was expected" - Location.print_filename file name id + fprintf ppf "Wrong file naming: %a@ contains the code for\ + @ %s when %s was expected" + Location.print_filename file name id | Forward_reference(file, ident) -> fprintf ppf "Forward reference to %s in file %a" ident Location.print_filename file diff --git a/asmcomp/compilenv.ml b/asmcomp/compilenv.ml index 1b1f1e9cc6..17870c932a 100644 --- a/asmcomp/compilenv.ml +++ b/asmcomp/compilenv.ml @@ -233,5 +233,6 @@ let report_error ppf = function fprintf ppf "Corrupted compilation unit description@ %a" Location.print_filename filename | Illegal_renaming(name, modname, filename) -> - fprintf ppf "%a@ contains the description for unit @ %s when %s was expected" + fprintf ppf "%a@ contains the description for unit\ + @ %s when %s was expected" Location.print_filename filename name modname diff --git a/asmcomp/i386/proc.ml b/asmcomp/i386/proc.ml index 4cecb2d44f..e946f699ba 100644 --- a/asmcomp/i386/proc.ml +++ b/asmcomp/i386/proc.ml @@ -200,4 +200,3 @@ let assemble_file infile outfile = Filename.quote outfile ^ " " ^ Filename.quote infile) let init () = () - diff --git a/asmcomp/power/arch.ml b/asmcomp/power/arch.ml index 4e31a8c155..cbeba916b5 100644 --- a/asmcomp/power/arch.ml +++ b/asmcomp/power/arch.ml @@ -12,7 +12,6 @@ (* Specific operations for the PowerPC processor *) -open Misc open Format (* Machine-specific command-line options *) diff --git a/asmcomp/power/emit.mlp b/asmcomp/power/emit.mlp index 4e7b0789a9..283312e7e1 100644 --- a/asmcomp/power/emit.mlp +++ b/asmcomp/power/emit.mlp @@ -15,7 +15,6 @@ module StringSet = Set.Make(struct type t = string let compare (x:t) y = compare x y end) -open Location open Misc open Cmm open Arch @@ -57,7 +56,7 @@ let supports_backtraces = let emit_symbol = match Config.system with - | "elf" | "bsd" -> (fun s -> Emitaux.emit_symbol '.' s) + | "elf" | "bsd" | "bsd_elf" -> (fun s -> Emitaux.emit_symbol '.' s) | "rhapsody" -> (fun s -> emit_char '_'; Emitaux.emit_symbol '$' s) | _ -> assert false @@ -65,7 +64,7 @@ let emit_symbol = let label_prefix = match Config.system with - | "elf" | "bsd" -> ".L" + | "elf" | "bsd" | "bsd_elf" -> ".L" | "rhapsody" -> "L" | _ -> assert false @@ -79,19 +78,19 @@ let emit_data_label lbl = let data_space = match Config.system with - | "elf" | "bsd" -> " .section \".data\"\n" + | "elf" | "bsd" | "bsd_elf" -> " .section \".data\"\n" | "rhapsody" -> " .data\n" | _ -> assert false let code_space = match Config.system with - | "elf" | "bsd" -> " .section \".text\"\n" + | "elf" | "bsd" | "bsd_elf" -> " .section \".text\"\n" | "rhapsody" -> " .text\n" | _ -> assert false let rodata_space = match Config.system with - | "elf" | "bsd" -> " .section \".rodata\"\n" + | "elf" | "bsd" | "bsd_elf" -> " .section \".rodata\"\n" | "rhapsody" -> " .const\n" | _ -> assert false @@ -159,7 +158,7 @@ let is_native_immediate n = let emit_upper emit_fun arg = match Config.system with - | "elf" | "bsd" -> + | "elf" | "bsd" | "bsd_elf" -> emit_fun arg; emit_string "@ha" | "rhapsody" -> emit_string "ha16("; emit_fun arg; emit_string ")" @@ -167,7 +166,7 @@ let emit_upper emit_fun arg = let emit_lower emit_fun arg = match Config.system with - | "elf" | "bsd" -> + | "elf" | "bsd" | "bsd_elf" -> emit_fun arg; emit_string "@l" | "rhapsody" -> emit_string "lo16("; emit_fun arg; emit_string ")" @@ -820,7 +819,7 @@ let rec emit_all i = match i with {desc = Lend} -> () | {next = {desc = (Lcondbranch(_, _) | Lcondbranch3(_, _, _))}} - when is_simple_instr i & no_interference i.res i.next.arg -> + when is_simple_instr i && no_interference i.res i.next.arg -> emit_instr i.next (Some i); emit_all i.next.next | _ -> @@ -845,7 +844,7 @@ let fundecl fundecl = else ` .globl {emit_symbol fundecl.fun_name}\n`; begin match Config.system with - | "elf" | "bsd" -> + | "elf" | "bsd" | "bsd_elf" -> ` .type {emit_symbol fundecl.fun_name}, @function\n` | _ -> () end; @@ -890,8 +889,11 @@ let fundecl fundecl = let declare_global_data s = ` .globl {emit_symbol s}\n`; - if Config.system = "elf" || Config.system = "bsd" then + match Config.system with + | "elf" | "bsd" | "bsd_elf" -> ` .type {emit_symbol s}, @object\n` + | "rhapsody" -> () + | _ -> assert false let emit_item = function Cglobal_symbol s -> diff --git a/asmcomp/power/proc.ml b/asmcomp/power/proc.ml index 38adadc05a..203e8a9ef4 100644 --- a/asmcomp/power/proc.ml +++ b/asmcomp/power/proc.ml @@ -186,7 +186,7 @@ let poweropen_external_conventions first_int last_int let loc_external_arguments = match Config.system with | "rhapsody" -> poweropen_external_conventions 0 7 100 112 - | "elf" | "bsd" -> calling_conventions 0 7 100 107 outgoing 8 + | "elf" | "bsd" | "bsd_elf" -> calling_conventions 0 7 100 107 outgoing 8 | _ -> assert false let extcall_use_push = false @@ -235,7 +235,4 @@ let assemble_file infile outfile = Ccomp.command (Config.asm ^ " -o " ^ Filename.quote outfile ^ " " ^ Filename.quote infile) -open Clflags;; -open Config;; - let init () = () diff --git a/asmcomp/power/selection.ml b/asmcomp/power/selection.ml index 41b6e9fa7f..a68c63fccc 100644 --- a/asmcomp/power/selection.ml +++ b/asmcomp/power/selection.ml @@ -12,9 +12,7 @@ (* Instruction selection for the Power PC processor *) -open Misc open Cmm -open Reg open Arch open Mach diff --git a/asmrun/Makefile b/asmrun/Makefile index 89adaa2e0c..5ebf7aadbd 100644 --- a/asmrun/Makefile +++ b/asmrun/Makefile @@ -81,6 +81,9 @@ install-prof: cp libasmrunp.a $(LIBDIR)/libasmrunp.a cd $(LIBDIR); $(RANLIB) libasmrunp.a +power-bsd_elf.S: power-elf.S + cp power-elf.S power-bsd_elf.S + power.o: power-$(SYSTEM).o cp power-$(SYSTEM).o power.o diff --git a/asmrun/amd64.S b/asmrun/amd64.S index 4a5218f269..aed5a964fb 100644 --- a/asmrun/amd64.S +++ b/asmrun/amd64.S @@ -74,7 +74,7 @@ #endif #ifdef WITH_FRAME_POINTERS - + #define ENTER_FUNCTION \ pushq %rbp; CFI_ADJUST(8); \ movq %rsp, %rbp @@ -89,7 +89,7 @@ addq $8, %rsp; CFI_ADJUST (-8); #endif - + #if defined(__PIC__) && !defined(SYS_mingw64) /* Position-independent operations on global variables. */ @@ -135,7 +135,7 @@ /* Load address of global [label] in register [dst]. */ #define LEA_VAR(label,dst) \ - movq GREL(label)(%rip), dst + movq GREL(label)(%rip), dst #else @@ -166,7 +166,7 @@ STORE_VAR(%rax,caml_bottom_of_stack) #define LEA_VAR(label,dst) \ - leaq G(label)(%rip), dst + leaq G(label)(%rip), dst #endif /* Save and restore all callee-save registers on stack. @@ -273,9 +273,9 @@ LBL(caml_call_gc): #endif /* Build array of registers, save it into caml_gc_regs */ #ifdef WITH_FRAME_POINTERS - ENTER_FUNCTION ; + ENTER_FUNCTION ; #else - pushq %rbp; CFI_ADJUST(8); + pushq %rbp; CFI_ADJUST(8); #endif pushq %r11; CFI_ADJUST (8); pushq %r10; CFI_ADJUST (8); @@ -349,9 +349,9 @@ LBL(caml_call_gc): popq %r10; CFI_ADJUST(-8) popq %r11; CFI_ADJUST(-8) #ifdef WITH_FRAME_POINTERS - LEAVE_FUNCTION + LEAVE_FUNCTION #else - popq %rbp; CFI_ADJUST(-8); + popq %rbp; CFI_ADJUST(-8); #endif /* Return to caller */ ret @@ -366,11 +366,11 @@ LBL(caml_alloc1): ret LBL(100): RECORD_STACK_FRAME(0) - ENTER_FUNCTION + ENTER_FUNCTION /* subq $8, %rsp; CFI_ADJUST (8); */ call LBL(caml_call_gc) /* addq $8, %rsp; CFI_ADJUST (-8); */ - LEAVE_FUNCTION + LEAVE_FUNCTION jmp LBL(caml_alloc1) CFI_ENDPROC @@ -383,11 +383,11 @@ LBL(caml_alloc2): ret LBL(101): RECORD_STACK_FRAME(0) - ENTER_FUNCTION + ENTER_FUNCTION /* subq $8, %rsp; CFI_ADJUST (8); */ call LBL(caml_call_gc) /* addq $8, %rsp; CFI_ADJUST (-8); */ - LEAVE_FUNCTION + LEAVE_FUNCTION jmp LBL(caml_alloc2) CFI_ENDPROC @@ -400,11 +400,11 @@ LBL(caml_alloc3): ret LBL(102): RECORD_STACK_FRAME(0) - ENTER_FUNCTION + ENTER_FUNCTION /* subq $8, %rsp; CFI_ADJUST (8) */ call LBL(caml_call_gc) /* addq $8, %rsp; CFI_ADJUST (-8) */ - LEAVE_FUNCTION + LEAVE_FUNCTION jmp LBL(caml_alloc3) CFI_ENDPROC @@ -420,12 +420,12 @@ LBL(caml_allocN): LBL(103): RECORD_STACK_FRAME(8) #ifdef WITH_FRAME_POINTERS - /* Do we need 16-byte alignment here ? */ - ENTER_FUNCTION + /* Do we need 16-byte alignment here ? */ + ENTER_FUNCTION #endif call LBL(caml_call_gc) #ifdef WITH_FRAME_POINTERS - LEAVE_FUNCTION + LEAVE_FUNCTION #endif popq %rax; CFI_ADJUST(-8) /* recover desired size */ jmp LBL(caml_allocN) @@ -535,8 +535,8 @@ LBL(110): movq %rax, %r12 /* Save exception bucket */ movq %rax, C_ARG_1 /* arg 1: exception bucket */ #ifdef WITH_FRAME_POINTERS - ENTER_FUNCTION - movq 8(%rsp), C_ARG_2 /* arg 2: pc of raise */ + ENTER_FUNCTION + movq 8(%rsp), C_ARG_2 /* arg 2: pc of raise */ leaq 16(%rsp), C_ARG_3 /* arg 3: sp at raise */ #else popq C_ARG_2 /* arg 2: pc of raise */ @@ -544,7 +544,7 @@ LBL(110): #endif movq %r14, C_ARG_4 /* arg 4: sp of handler */ /* PR#5700: thanks to popq above, stack is now 16-aligned */ - /* Thanks to ENTER_FUNCTION, stack is now 16-aligned */ + /* Thanks to ENTER_FUNCTION, stack is now 16-aligned */ PREPARE_FOR_C_CALL /* no need to cleanup after */ call GCALL(caml_stash_backtrace) movq %r12, %rax /* Recover exception bucket */ @@ -566,7 +566,7 @@ CFI_STARTPROC ret LBL(111): #ifdef WITH_FRAME_POINTERS - ENTER_FUNCTION ; + ENTER_FUNCTION ; #endif movq C_ARG_1, %r12 /* Save exception bucket */ /* arg 1: exception bucket */ @@ -587,7 +587,7 @@ CFI_ENDPROC /* Raise a Stack_overflow exception on return from segv_handler() (in asmrun/signals_asm.c). On entry, the stack is full, so we - cannot record a backtrace. + cannot record a backtrace. No CFI information here since this function disrupts the stack backtrace anyway. */ diff --git a/asmrun/backtrace.c b/asmrun/backtrace.c index 3ca182413f..3854967cf4 100644 --- a/asmrun/backtrace.c +++ b/asmrun/backtrace.c @@ -55,56 +55,75 @@ CAMLprim value caml_backtrace_status(value vunit) return Val_bool(caml_backtrace_active); } -/* Store the return addresses contained in the given stack fragment - into the backtrace array */ +/* returns the next frame descriptor (or NULL if none is available), + and updates *pc and *sp to point to the following one. */ -void caml_stash_backtrace(value exn, uintnat pc, char * sp, char * trapsp) +frame_descr * caml_next_frame_descriptor(uintnat * pc, char ** sp) { frame_descr * d; uintnat h; - if (exn != caml_backtrace_last_exn) { - caml_backtrace_pos = 0; - caml_backtrace_last_exn = exn; - } - if (caml_backtrace_buffer == NULL) { - caml_backtrace_buffer = malloc(BACKTRACE_BUFFER_SIZE * sizeof(code_t)); - if (caml_backtrace_buffer == NULL) return; - } if (caml_frame_descriptors == NULL) caml_init_frame_descriptors(); while (1) { - /* Find the descriptor corresponding to the return address */ - h = Hash_retaddr(pc); - while(1) { + h = Hash_retaddr(*pc); + while (1) { d = caml_frame_descriptors[h]; - if (d == 0) return; /* can happen if some code not compiled with -g */ - if (d->retaddr == pc) break; + if (d == 0) return NULL; /* can happen if some code compiled without -g */ + if (d->retaddr == *pc) break; h = (h+1) & caml_frame_descriptors_mask; } /* Skip to next frame */ if (d->frame_size != 0xFFFF) { - /* Regular frame, store its descriptor in the backtrace buffer */ - if (caml_backtrace_pos >= BACKTRACE_BUFFER_SIZE) return; - caml_backtrace_buffer[caml_backtrace_pos++] = (code_t) d; + /* Regular frame, update sp/pc and return the frame descriptor */ #ifndef Stack_grows_upwards - sp += (d->frame_size & 0xFFFC); + *sp += (d->frame_size & 0xFFFC); #else - sp -= (d->frame_size & 0xFFFC); + *sp -= (d->frame_size & 0xFFFC); #endif - pc = Saved_return_address(sp); + *pc = Saved_return_address(*sp); #ifdef Mask_already_scanned - pc = Mask_already_scanned(pc); + *pc = Mask_already_scanned(*pc); #endif + return d; } else { /* Special frame marking the top of a stack chunk for an ML callback. Skip C portion of stack and continue with next ML stack chunk. */ - struct caml_context * next_context = Callback_link(sp); - sp = next_context->bottom_of_stack; - pc = next_context->last_retaddr; + struct caml_context * next_context = Callback_link(*sp); + *sp = next_context->bottom_of_stack; + *pc = next_context->last_retaddr; /* A null sp means no more ML stack chunks; stop here. */ - if (sp == NULL) return; + if (*sp == NULL) return NULL; } + } +} + +/* Stores the return addresses contained in the given stack fragment + into the backtrace array ; this version is performance-sensitive as + it is called at each [raise] in a program compiled with [-g], so we + preserved the global, statically bounded buffer of the old + implementation -- before the more flexible + [caml_get_current_callstack] was implemented. */ + +void caml_stash_backtrace(value exn, uintnat pc, char * sp, char * trapsp) +{ + if (exn != caml_backtrace_last_exn) { + caml_backtrace_pos = 0; + caml_backtrace_last_exn = exn; + } + if (caml_backtrace_buffer == NULL) { + caml_backtrace_buffer = malloc(BACKTRACE_BUFFER_SIZE * sizeof(code_t)); + if (caml_backtrace_buffer == NULL) return; + } + + /* iterate on each frame */ + while (1) { + frame_descr * descr = caml_next_frame_descriptor(&pc, &sp); + if (descr == NULL) return; + /* store its descriptor in the backtrace buffer */ + if (caml_backtrace_pos >= BACKTRACE_BUFFER_SIZE) return; + caml_backtrace_buffer[caml_backtrace_pos++] = (code_t) descr; + /* Stop when we reach the current exception handler */ #ifndef Stack_grows_upwards if (sp > trapsp) return; @@ -114,6 +133,67 @@ void caml_stash_backtrace(value exn, uintnat pc, char * sp, char * trapsp) } } +/* Stores upto [max_frames_value] frames of the current call stack to + return to the user. This is used not in an exception-raising + context, but only when the user requests to save the trace + (hopefully less often). Instead of using a bounded buffer as + [caml_stash_backtrace], we first traverse the stack to compute the + right size, then allocate space for the trace. */ + +CAMLprim value caml_get_current_callstack(value max_frames_value) { + CAMLparam1(max_frames_value); + CAMLlocal1(trace); + + /* we use `intnat` here because, were it only `int`, passing `max_int` + from the OCaml side would overflow on 64bits machines. */ + intnat max_frames = Long_val(max_frames_value); + intnat trace_size; + + /* first compute the size of the trace */ + { + uintnat pc = caml_last_return_address; + /* note that [caml_bottom_of_stack] always points to the most recent + * frame, independently of the [Stack_grows_upwards] setting */ + char * sp = caml_bottom_of_stack; + char * limitsp = caml_top_of_stack; + + trace_size = 0; + while (1) { + frame_descr * descr = caml_next_frame_descriptor(&pc, &sp); + if (descr == NULL) break; + if (trace_size >= max_frames) break; + ++trace_size; + +#ifndef Stack_grows_upwards + if (sp > limitsp) break; +#else + if (sp < limitsp) break; +#endif + } + } + + trace = caml_alloc((mlsize_t) trace_size, Abstract_tag); + + /* then collect the trace */ + { + uintnat pc = caml_last_return_address; + char * sp = caml_bottom_of_stack; + intnat trace_pos; + + for (trace_pos = 0; trace_pos < trace_size; trace_pos++) { + frame_descr * descr = caml_next_frame_descriptor(&pc, &sp); + Assert(descr != NULL); + /* The assignment below is safe without [caml_initialize], even + if the trace is large and allocated on the old heap, because + we assign values that are outside the OCaml heap. */ + Assert(!(Is_block((value) descr) && Is_in_heap((value) descr))); + Field(trace, trace_pos) = (value) descr; + } + } + + CAMLreturn(trace); +} + /* Extract location information for the given frame descriptor */ struct loc_info { @@ -163,22 +243,41 @@ static void extract_location_info(frame_descr * d, li->loc_endchr = ((info2 & 0xF) << 6) | (info1 >> 26); } +/* Print location information -- same behavior as in Printexc + + note that the test for compiler-inserted raises is slightly redundant: + (!li->loc_valid && li->loc_is_raise) + extract_location_info above guarantees that when li->loc_valid is + 0, then li->loc_is_raise is always 1, so the latter test is + useless. We kept it to keep code identical to the byterun/ + implementation. */ + static void print_location(struct loc_info * li, int index) { char * info; /* Ignore compiler-inserted raise */ - if (!li->loc_valid) return; - - if (index == 0) - info = "Raised at"; - else if (li->loc_is_raise) - info = "Re-raised at"; - else - info = "Called from"; - fprintf (stderr, "%s file \"%s\", line %d, characters %d-%d\n", - info, li->loc_filename, li->loc_lnum, - li->loc_startchr, li->loc_endchr); + if (!li->loc_valid && li->loc_is_raise) return; + + if (li->loc_is_raise) { + /* Initial raise if index == 0, re-raise otherwise */ + if (index == 0) + info = "Raised at"; + else + info = "Re-raised at"; + } else { + if (index == 0) + info = "Raised by primitive operation at"; + else + info = "Called from"; + } + if (! li->loc_valid) { + fprintf(stderr, "%s unknown location\n", info); + } else { + fprintf (stderr, "%s file \"%s\", line %d, characters %d-%d\n", + info, li->loc_filename, li->loc_lnum, + li->loc_startchr, li->loc_endchr); + } } /* Print a backtrace */ diff --git a/asmrun/signals_asm.c b/asmrun/signals_asm.c index 9bc86cfdc5..4f62bd38a9 100644 --- a/asmrun/signals_asm.c +++ b/asmrun/signals_asm.c @@ -215,7 +215,7 @@ DECLARE_SIGNAL_HANDLER(segv_handler) ) { #ifdef RETURN_AFTER_STACK_OVERFLOW /* Tweak the PC part of the context so that on return from this - handler, we jump to the asm function [caml_stack_overflow] + handler, we jump to the asm function [caml_stack_overflow] (from $ARCH.S). */ #ifdef CONTEXT_PC CONTEXT_PC = (context_reg) &caml_stack_overflow; diff --git a/asmrun/signals_osdep.h b/asmrun/signals_osdep.h index 5e07b2c2df..ff1984754a 100644 --- a/asmrun/signals_osdep.h +++ b/asmrun/signals_osdep.h @@ -237,7 +237,7 @@ /****************** PowerPC, BSD */ -#elif defined(TARGET_power) && defined(SYS_bsd) +#elif defined(TARGET_power) && (defined(SYS_bsd) || defined(SYS_bsd_elf)) #define DECLARE_SIGNAL_HANDLER(name) \ static void name(int sig, int code, struct sigcontext * context) diff --git a/boot/ocamlc b/boot/ocamlc Binary files differindex d240b93757..66c9208b3a 100755 --- a/boot/ocamlc +++ b/boot/ocamlc diff --git a/boot/ocamldep b/boot/ocamldep Binary files differindex 4e198ac5b3..3a2eb6ccf4 100755 --- a/boot/ocamldep +++ b/boot/ocamldep diff --git a/boot/ocamllex b/boot/ocamllex Binary files differindex 53cdb4656e..74047e3c5c 100755 --- a/boot/ocamllex +++ b/boot/ocamllex diff --git a/bytecomp/bytelink.ml b/bytecomp/bytelink.ml index de7bfbfa16..0ac87050bd 100644 --- a/bytecomp/bytelink.ml +++ b/bytecomp/bytelink.ml @@ -254,7 +254,9 @@ let link_file ppf output_fun currpos_fun = function let output_debug_info oc = output_binary_int oc (List.length !debug_info); List.iter - (fun (ofs, evl) -> output_binary_int oc ofs; Array.iter (output_string oc) evl) + (fun (ofs, evl) -> + output_binary_int oc ofs; + Array.iter (output_string oc) evl) !debug_info; debug_info := [] @@ -521,7 +523,8 @@ let link ppf objfiles output_name = else "stdlib.cma" :: (objfiles @ ["std_exit.cmo"]) in let tolink = List.fold_right scan_file objfiles [] in Clflags.ccobjs := !Clflags.ccobjs @ !lib_ccobjs; (* put user's libs last *) - Clflags.all_ccopts := !lib_ccopts @ !Clflags.all_ccopts; (* put user's opts first *) + Clflags.all_ccopts := !lib_ccopts @ !Clflags.all_ccopts; + (* put user's opts first *) Clflags.dllibs := !lib_dllibs @ !Clflags.dllibs; (* put user's DLLs first *) if not !Clflags.custom_runtime then link_bytecode ppf tolink output_name true diff --git a/bytecomp/bytepackager.ml b/bytecomp/bytepackager.ml index 3015232b0b..f548c771a7 100644 --- a/bytecomp/bytepackager.ml +++ b/bytecomp/bytepackager.ml @@ -271,7 +271,8 @@ let report_error ppf = function fprintf ppf "%a is not a bytecode object file" Location.print_filename file | Illegal_renaming(name, file, id) -> - fprintf ppf "Wrong file naming: %a@ contains the code for @ %s when %s was expected" - Location.print_filename file name id + fprintf ppf "Wrong file naming: %a@ contains the code for\ + @ %s when %s was expected" + Location.print_filename file name id | File_not_found file -> fprintf ppf "File %s not found" file diff --git a/bytecomp/dll.ml b/bytecomp/dll.ml index cdc4058900..c370b4311c 100644 --- a/bytecomp/dll.ml +++ b/bytecomp/dll.ml @@ -128,12 +128,14 @@ let read_ld_conf_contents dir = List.rev !path let ld_conf_contents () = - read_ld_conf_contents Config.standard_library @ + read_ld_conf_contents Config.standard_library +(* Not needed anymore, as out ld.conf already includes those *) +(* @ begin match Config.ocaml_library with | None -> [] | Some dir -> read_ld_conf_contents dir end - +*) (* Split the CAML_LD_LIBRARY_PATH environment variable and return the corresponding list of directories. *) diff --git a/bytecomp/matching.ml b/bytecomp/matching.ml index bd6b1c32cf..b8e972c5f8 100644 --- a/bytecomp/matching.ml +++ b/bytecomp/matching.ml @@ -2484,7 +2484,7 @@ and compile_no_test divide up_ctx repr partial ctx to_match = (* The entry points *) (* - If there is a guard in a matching or a lazy pattern, + If there is a guard in a matching or a lazy pattern, then set exhaustiveness info to Partial. (because of side effects, assume the worst). @@ -2542,7 +2542,7 @@ let have_mutable_field p = match p with | Tpat_or _ | Tpat_constant _ | Tpat_var _ | Tpat_any -> false - + let is_mutable p = find_in_pat have_mutable_field p (* Downgrade Total when diff --git a/bytecomp/translmod.ml b/bytecomp/translmod.ml index 4092d59f6b..f1c21adc80 100644 --- a/bytecomp/translmod.ml +++ b/bytecomp/translmod.ml @@ -228,6 +228,19 @@ let compile_recmodule compile_rhs bindings cont = bindings)) cont +(* Extract the list of "value" identifiers bound by a signature. + "Value" identifiers are identifiers for signature components that + correspond to a run-time value: values, exceptions, modules, classes. + Note: manifest primitives do not correspond to a run-time value! *) + +let rec bound_value_identifiers = function + [] -> [] + | Sig_value(id, {val_kind = Val_reg}) :: rem -> + id :: bound_value_identifiers rem + | Sig_exception(id, decl) :: rem -> id :: bound_value_identifiers rem + | Sig_module(id, mty, _) :: rem -> id :: bound_value_identifiers rem + | Sig_class(id, decl, _) :: rem -> id :: bound_value_identifiers rem + | _ :: rem -> bound_value_identifiers rem (* Compile a module expression *) @@ -338,7 +351,8 @@ and transl_structure fields cc rootpath = function transl_structure (List.rev ids @ fields) cc rootpath rem) | Tstr_class_type cl_list -> transl_structure fields cc rootpath rem - | Tstr_include(modl, ids) -> + | Tstr_include(modl, sg) -> + let ids = bound_value_identifiers sg in let mid = Ident.create "include" in let rec rebind_idents pos newfields = function [] -> @@ -390,7 +404,7 @@ let rec defined_idents = function | Tstr_class cl_list -> List.map (fun (ci, _, _) -> ci.ci_id_class) cl_list @ defined_idents rem | Tstr_class_type cl_list -> defined_idents rem - | Tstr_include(modl, ids) -> ids @ defined_idents rem + | Tstr_include(modl, sg) -> bound_value_identifiers sg @ defined_idents rem (* second level idents (module M = struct ... let id = ... end), and all sub-levels idents *) @@ -413,7 +427,7 @@ let rec more_idents = function | Tstr_open _ -> more_idents rem | Tstr_class cl_list -> more_idents rem | Tstr_class_type cl_list -> more_idents rem - | Tstr_include(modl, ids) -> more_idents rem + | Tstr_include(modl, _) -> more_idents rem | Tstr_module(id, _, { mod_desc = Tmod_structure str }) -> all_idents str.str_items @ more_idents rem | Tstr_module(id, _, _) -> more_idents rem @@ -440,7 +454,7 @@ and all_idents = function | Tstr_class cl_list -> List.map (fun (ci, _, _) -> ci.ci_id_class) cl_list @ all_idents rem | Tstr_class_type cl_list -> all_idents rem - | Tstr_include(modl, ids) -> ids @ all_idents rem + | Tstr_include(modl, sg) -> bound_value_identifiers sg @ all_idents rem | Tstr_module(id, _, { mod_desc = Tmod_structure str }) -> id :: all_idents str.str_items @ all_idents rem | Tstr_module(id, _, _) -> id :: all_idents rem @@ -557,7 +571,8 @@ let transl_store_structure glob map prims str = transl_store rootpath (add_idents false ids subst) rem) | Tstr_class_type cl_list -> transl_store rootpath subst rem - | Tstr_include(modl, ids) -> + | Tstr_include(modl, sg) -> + let ids = bound_value_identifiers sg in let mid = Ident.create "include" in let rec store_idents pos = function [] -> transl_store rootpath (add_idents true ids subst) rem @@ -757,7 +772,8 @@ let transl_toplevel_item item = cl_list) | Tstr_class_type cl_list -> lambda_unit - | Tstr_include(modl, ids) -> + | Tstr_include(modl, sg) -> + let ids = bound_value_identifiers sg in let mid = Ident.create "include" in let rec set_idents pos = function [] -> diff --git a/byterun/Makefile.common b/byterun/Makefile.common index 567834727d..b0d15de782 100755 --- a/byterun/Makefile.common +++ b/byterun/Makefile.common @@ -47,6 +47,7 @@ all-runtimed: ocamlrund$(EXE) libcamlrund.$(A) ld.conf: ../config/Makefile echo "$(STUBLIBDIR)" > ld.conf echo "$(LIBDIR)" >> ld.conf + -test -f $(OCAMLLIB)/ld.conf && cat $(OCAMLLIB)/ld.conf >> ld.conf install:: cp ocamlrun$(EXE) $(BINDIR)/jocamlrun$(EXE) @@ -80,11 +81,12 @@ install-runtimed: # the bytecode interpreter is confused). # We sort the primitive file and remove duplicates to avoid this problem. +# Warning: we use "sort | uniq" instead of "sort -u" because in the MSVC +# port, the "sort" program in the path is Microsoft's and not cygwin's + primitives : $(PRIMS) - sed -n -e "s/CAMLprim value \([a-z0-9_][a-z0-9_]*\).*/\1/p" \ - $(PRIMS) > primitives.tmp - sort primitives.tmp | uniq > primitives - rm primitives.tmp + sed -n -e "s/CAMLprim value \([a-z0-9_][a-z0-9_]*\).*/\1/p" $(PRIMS) \ + | sort | uniq > primitives prims.c : primitives (echo '#include "mlvalues.h"'; \ diff --git a/byterun/backtrace.c b/byterun/backtrace.c index 9e894f2164..4098e47e20 100644 --- a/byterun/backtrace.c +++ b/byterun/backtrace.c @@ -107,6 +107,7 @@ void caml_stash_backtrace(value exn, code_t pc, value * sp) } if (caml_backtrace_pos >= BACKTRACE_BUFFER_SIZE) return; if (pc >= caml_start_code && pc < end_code){ + /* testing the code region is needed: PR#1554 */ caml_backtrace_buffer[caml_backtrace_pos++] = pc; } for (/*nothing*/; sp < caml_trapsp; sp++) { @@ -118,6 +119,74 @@ void caml_stash_backtrace(value exn, code_t pc, value * sp) } } +/* returns the next frame pointer (or NULL if none is available); + updates *sp to point to the following one, and *trapsp to the next + trap frame, which we will skip when we reach it */ + +code_t caml_next_frame_pointer(value ** sp, value ** trapsp) +{ + code_t end_code = (code_t) ((char *) caml_start_code + caml_code_size); + + while (*sp < caml_stack_high) { + code_t *p = (code_t*) (*sp)++; + if(&Trap_pc(*trapsp) == p) { + *trapsp = Trap_link(*trapsp); + continue; + } + if (*p >= caml_start_code && *p < end_code) return *p; + } + return NULL; +} + +/* Stores upto [max_frames_value] frames of the current call stack to + return to the user. This is used not in an exception-raising + context, but only when the user requests to save the trace + (hopefully less often). Instead of using a bounded buffer as + [caml_stash_backtrace], we first traverse the stack to compute the + right size, then allocate space for the trace. */ + +CAMLprim value caml_get_current_callstack(value max_frames_value) { + CAMLparam1(max_frames_value); + CAMLlocal1(trace); + + /* we use `intnat` here because, were it only `int`, passing `max_int` + from the OCaml side would overflow on 64bits machines. */ + intnat max_frames = Long_val(max_frames_value); + intnat trace_size; + + /* first compute the size of the trace */ + { + value * sp = caml_extern_sp; + value * trapsp = caml_trapsp; + + for (trace_size = 0; trace_size < max_frames; trace_size++) { + code_t p = caml_next_frame_pointer(&sp, &trapsp); + if (p == NULL) break; + } + } + + trace = caml_alloc(trace_size, Abstract_tag); + + /* then collect the trace */ + { + value * sp = caml_extern_sp; + value * trapsp = caml_trapsp; + uintnat trace_pos; + + for (trace_pos = 0; trace_pos < trace_size; trace_pos++) { + code_t p = caml_next_frame_pointer(&sp, &trapsp); + Assert(p != NULL); + /* The assignment below is safe without [caml_initialize], even + if the trace is large and allocated on the old heap, because + we assign values that are outside the OCaml heap. */ + Assert(!(Is_block((value) p) && Is_in_heap((value) p))); + Field(trace, trace_pos) = (value) p; + } + } + + CAMLreturn(trace); +} + /* Read the debugging info contained in the current bytecode executable. Return an OCaml array of OCaml lists of debug_event records in "events", or Val_false on failure. */ @@ -126,6 +195,7 @@ void caml_stash_backtrace(value exn, code_t pc, value * sp) #define O_BINARY 0 #endif +static char *read_debug_info_error = ""; static value read_debug_info(void) { CAMLparam0(); @@ -143,10 +213,14 @@ static value read_debug_info(void) exec_name = caml_exe_name; } fd = caml_attempt_open(&exec_name, &trail, 1); - if (fd < 0) CAMLreturn(Val_false); + if (fd < 0){ + read_debug_info_error = "executable program file not found"; + CAMLreturn(Val_false); + } caml_read_section_descriptors(fd, &trail); if (caml_seek_optional_section(fd, &trail, "DBUG") == -1) { close(fd); + read_debug_info_error = "program not linked with -g"; CAMLreturn(Val_false); } chan = caml_open_descriptor_in(fd); @@ -225,7 +299,7 @@ static void extract_location_info(value events, code_t pc, - Int_val (Field (ev_start, POS_BOL)); } -/* Print location information */ +/* Print location information -- same behavior as in Printexc */ static void print_location(struct loc_info * li, int index) { @@ -265,8 +339,8 @@ CAMLexport void caml_print_exception_backtrace(void) events = read_debug_info(); if (events == Val_false) { - fprintf(stderr, - "(Program not linked with -g, cannot print stack backtrace)\n"); + fprintf(stderr, "(Cannot print stack backtrace: %s)\n", + read_debug_info_error); return; } for (i = 0; i < caml_backtrace_pos; i++) { diff --git a/byterun/extern.c b/byterun/extern.c index 16454516fe..a2bc629538 100644 --- a/byterun/extern.c +++ b/byterun/extern.c @@ -33,7 +33,7 @@ static uintnat size_64; /* Size in words of 64-bit block for struct. */ /* Flags affecting marshaling */ -enum { +enum { NO_SHARING = 1, /* Flag to ignore sharing */ CLOSURES = 2, /* Flag to allow marshaling code pointers */ COMPAT_32 = 4 /* Flag to ensure that output can safely diff --git a/byterun/gc_ctrl.c b/byterun/gc_ctrl.c index 07cfc26d2a..84327fa289 100644 --- a/byterun/gc_ctrl.c +++ b/byterun/gc_ctrl.c @@ -401,7 +401,7 @@ CAMLprim value caml_gc_set(value v) /* Minor heap size comes last because it will trigger a minor collection (thus invalidating [v]) and it can raise [Out_of_memory]. */ - newminsize = norm_minsize (Bsize_wsize (Long_val (Field (v, 0)))); + newminsize = Bsize_wsize (norm_minsize (Long_val (Field (v, 0)))); if (newminsize != caml_minor_heap_size){ caml_gc_message (0x20, "New minor heap size: %luk bytes\n", newminsize/1024); diff --git a/byterun/memory.c b/byterun/memory.c index e18bde45c1..54d91c96da 100644 --- a/byterun/memory.c +++ b/byterun/memory.c @@ -502,7 +502,8 @@ CAMLexport void caml_adjust_gc_speed (mlsize_t res, mlsize_t max) */ /* [caml_initialize] never calls the GC, so you may call it while a block is unfinished (i.e. just after a call to [caml_alloc_shr].) */ -CAMLexport void caml_initialize (value *fp, value val) +/* PR#6084 workaround: define it as a weak symbol */ +CAMLexport CAMLweakdef void caml_initialize (value *fp, value val) { CAMLassert(Is_in_heap(fp)); *fp = val; @@ -522,12 +523,12 @@ CAMLexport void caml_initialize (value *fp, value val) in the minor heap instead of in the major heap. In this case, it is a bit slower than simple assignment. In particular, you can use [caml_modify] when you don't know whether the - block being changed is in the minor heap or the major heap. -*/ + block being changed is in the minor heap or the major heap. */ +/* PR#6084 workaround: define it as a weak symbol */ -CAMLexport void caml_modify (value *fp, value val) +CAMLexport CAMLweakdef void caml_modify (value *fp, value val) { - /* The write barrier implemented by [caml_modify] checks for the + /* The write barrier implemented by [caml_modify] checks for the following two conditions and takes appropriate action: 1- a pointer from the major heap to the minor heap is created --> add [fp] to the remembered set diff --git a/byterun/minor_gc.c b/byterun/minor_gc.c index 3e0dd4e21e..b15d1e4469 100644 --- a/byterun/minor_gc.c +++ b/byterun/minor_gc.c @@ -71,13 +71,14 @@ static void clear_table (struct caml_ref_table *tbl) tbl->limit = tbl->threshold; } +/* size in bytes */ void caml_set_minor_heap_size (asize_t size) { char *new_heap; void *new_heap_base; - Assert (size >= Minor_heap_min); - Assert (size <= Minor_heap_max); + Assert (size >= Bsize_wsize(Minor_heap_min)); + Assert (size <= Bsize_wsize(Minor_heap_max)); Assert (size % sizeof (value) == 0); if (caml_young_ptr != caml_young_end) caml_minor_collection (); Assert (caml_young_ptr == caml_young_end); diff --git a/byterun/minor_gc.h b/byterun/minor_gc.h index 0258f4faa2..4727826d70 100644 --- a/byterun/minor_gc.h +++ b/byterun/minor_gc.h @@ -37,7 +37,7 @@ CAMLextern struct caml_ref_table caml_ref_table, caml_weak_ref_table; (Assert (Is_block (val)), \ (addr)(val) < (addr)caml_young_end && (addr)(val) > (addr)caml_young_start) -extern void caml_set_minor_heap_size (asize_t); +extern void caml_set_minor_heap_size (asize_t); /* size in bytes */ extern void caml_empty_minor_heap (void); CAMLextern void caml_minor_collection (void); CAMLextern void garbage_collection (void); /* def in asmrun/signals.c */ diff --git a/byterun/misc.h b/byterun/misc.h index 2529bc6128..4fd82af2d1 100644 --- a/byterun/misc.h +++ b/byterun/misc.h @@ -51,6 +51,14 @@ typedef char * addr; #define CAMLprim #define CAMLextern extern +/* Weak function definitions that can be overriden by external libs */ +/* Conservatively restricted to ELF and MacOSX platforms */ +#if defined(__GNUC__) && (defined (__ELF__) || defined(__APPLE__)) +#define CAMLweakdef __attribute__((weak)) +#else +#define CAMLweakdef +#endif + /* Assertions */ /* <private> */ diff --git a/byterun/startup.c b/byterun/startup.c index be55f484eb..7b9aad46fe 100644 --- a/byterun/startup.c +++ b/byterun/startup.c @@ -88,7 +88,8 @@ static void fixup_endianness_trailer(uint32 * p) static int read_trailer(int fd, struct exec_trailer *trail) { - lseek(fd, (long) -TRAILER_SIZE, SEEK_END); + if (lseek(fd, (long) -TRAILER_SIZE, SEEK_END) == -1) + return BAD_BYTECODE; if (read(fd, (char *) trail, TRAILER_SIZE) < TRAILER_SIZE) return BAD_BYTECODE; fixup_endianness_trailer(&trail->num_sections); @@ -46,6 +46,7 @@ partialld="ld -r" ocamlc='' withcamlp4="" with_frame_pointers=false +with_cfi=true # Try to turn internationalization off, can cause config.guess to malfunction! @@ -125,6 +126,8 @@ while : ; do withcamlp4="";; -with-frame-pointers|--with-frame-pointers) with_frame_pointers=true;; + -no-cfi|--no-cfi) + with_cfi=false;; *) echo "Unknown option \"$1\"." 1>&2; exit 2;; esac shift @@ -548,9 +551,9 @@ if $int64_native; then echo "#undef ARCH_ALIGN_INT64" >> m.h;; 1) echo "64-bit integers must be doubleword-aligned." echo "#define ARCH_ALIGN_INT64" >> m.h;; - *) echo "Something went wrong during alignment determination for 64-bit integers." - echo "I'm going to assume this architecture has alignment constraints." - echo "That's a safe bet: OCaml will work even if" + *) echo "Something went wrong during alignment determination for 64-bit" + echo "integers. I'm going to assume this architecture has alignment" + echo "constraints. That's a safe bet: OCaml will work even if" echo "this architecture has actually no alignment constraints." echo "#define ARCH_ALIGN_INT64" >> m.h;; esac @@ -563,11 +566,14 @@ fi sh ./runtest divmod.c case $? in - 0) echo "Native division and modulus have round-towards-zero semantics, will use them." + 0) echo "Native division and modulus have round-towards-zero semantics," + echo "will use them." echo "#undef NONSTANDARD_DIV_MOD" >> m.h;; - 1) echo "Native division and modulus do not have round-towards-zero semantics, will use software emulation." + 1) echo "Native division and modulus do not have round-towards-zero" + echo "semantics, will use software emulation." echo "#define NONSTANDARD_DIV_MOD" >> m.h;; - *) echo "Something went wrong while checking native division and modulus, please report it." + *) echo "Something went wrong while checking native division and modulus," + echo "please report it at http://http://caml.inria.fr/mantis/" echo "#define NONSTANDARD_DIV_MOD" >> m.h;; esac @@ -587,7 +593,7 @@ if test $withsharedlibs = "yes"; then mksharedlib="$flexlink" mkmaindll="$flexlink -maindll" shared_libraries_supported=true;; - *-*-linux-gnu|*-*-linux|*-*-freebsd[3-9]*|*-*-openbsd*|*-*-netbsd*|*-*-gnu*) + *-*-linux-gnu|*-*-linux|*-*-freebsd[3-9]*|*-*-freebsd[1-9][0-9]*|*-*-openbsd*|*-*-netbsd*|*-*-gnu*) sharedcccompopts="-fPIC" mksharedlib="$bytecc -shared" bytecclinkopts="$bytecclinkopts -Wl,-E" @@ -738,9 +744,10 @@ case "$host" in i[3456]86-*-gnu*) arch=i386; system=gnu;; powerpc*-*-linux*) arch=power; model=ppc; system=elf;; powerpc-*-netbsd*) arch=power; model=ppc; system=elf;; + powerpc-*-openbsd*) arch=power; model=ppc; system=bsd_elf;; powerpc-*-rhapsody*) arch=power; model=ppc; system=rhapsody;; powerpc-*-darwin*) arch=power; system=rhapsody - if $arch64; then model=ppc64; else model=ppc; fi;; + if $arch64;then model=ppc64;else model=ppc;fi;; armv6*-*-linux-gnueabihf) arch=arm; model=armv6; system=linux_eabihf;; arm*-*-linux-gnueabihf) arch=arm; system=linux_eabihf;; armv7*-*-linux-gnueabi) arch=arm; model=armv7; system=linux_eabi;; @@ -815,7 +822,7 @@ case "$arch,$model,$system" in aspp='gcc -c';; power,*,elf) as='as -u -m ppc' aspp='gcc -c';; - power,*,bsd) as='as' + power,*,bsd*) as='as' aspp='gcc -c';; power,*,rhapsody) as="as -arch $model" aspp="$bytecc -c";; @@ -1627,7 +1634,9 @@ asm_cfi_supported=false export as aspp -if sh ./tryassemble cfi.S; then +if ! $with_cfi; then + echo "CFI support: disabled by command-line option -no-cfi" +elif sh ./tryassemble cfi.S; then echo "#define ASM_CFI_SUPPORTED" >> m.h asm_cfi_supported=true echo "Assembler supports CFI" @@ -1636,14 +1645,14 @@ else fi if test "$with_frame_pointers" = "true"; then - nativecccompopts="$nativecccompopts -g" - nativecclinkopts="$nativecclinkopts -g" - echo "#define WITH_FRAME_POINTERS" >> m.h - - case "$cc" in - gcc*) - bytecccompopts="$bytecccompopts -fno-omit-frame-pointer" - nativecccompopts="$nativecccompopts -fno-omit-frame-pointer";; + case "$host,$cc" in + x86_64-*-linux*,gcc*) + nativecccompopts="$nativecccompopts -g -fno-omit-frame-pointer" + bytecccompopts="$bytecccompopts -g -fno-omit-frame-pointer" + nativecclinkopts="$nativecclinkopts -g" + echo "#define WITH_FRAME_POINTERS" >> m.h + ;; + *) echo "Unsupported architecture with frame pointers" 1>&2; exit 2;; esac fi diff --git a/driver/compenv.ml b/driver/compenv.ml index 5286d597fb..2ec10d8f13 100644 --- a/driver/compenv.ml +++ b/driver/compenv.ml @@ -2,9 +2,9 @@ (* *) (* OCaml *) (* *) -(* Fabrice Le Fessant, équipe Gallium, INRIA Rocquencourt *) +(* Fabrice Le Fessant, EPI Gallium, INRIA Paris-Rocquencourt *) (* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* 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. *) (* *) @@ -51,12 +51,6 @@ let default_output = function | Some s -> s | None -> Config.default_executable_name -(* Initialize the search path. - The current directory is always searched first, - then the directories specified with the -I option (in command-line order), - then the standard library directory (unless the -nostdlib option is given). - *) - let implicit_modules = ref [] let first_include_dirs = ref [] let last_include_dirs = ref [] @@ -97,75 +91,10 @@ let check_unit_name ppf filename name = type readenv_position = Before_args | Before_compile | Before_link -(* Syntax of OCAMLCOMPPARAM: (name=VALUE)(,name=VALUE)* where - VALUE=expression without , -*) +(* Syntax of OCAMLPARAM: (name=VALUE,)* _ (,name=VALUE)* + where VALUE should not contain ',' *) exception SyntaxError of string -(* -let parse_args s = - let len = String.length s in - let rec iter0 i pos0 = - if i = len then - if i = pos0 then [] - else raise (SyntaxError "End of line while expecting char '='") - else - let c = s.[i] in - let pos1 = i+1 in - if c = '=' then - iter1 pos1 pos1 (String.sub s pos0 (i-pos0)) - else iter0 pos1 pos0 - - and iter1 i pos0 name = - if i = len then [name, ""] - else - let c = s.[i] in - let pos1 = i+1 in - match c with - '"' -> - iter3 pos1 (Buffer.create 50) name - | ',' -> - (name, "") :: iter0 pos1 pos1 - | _ -> - iter2 pos1 pos0 name - - and iter2 i pos0 name = - if i = len then [name, String.sub s pos0 (len-pos0)] - else - let pos1 = i+1 in - match s.[i] with - | ',' -> - (name, String.sub s pos0 (i-pos0)) :: iter0 pos1 pos1 - | _ -> iter2 pos1 pos0 name - - and iter3 i b name = - if i = len then - raise (SyntaxError "End of line while expecting '\"'") - else - let pos1 = i+1 in - match s.[i] with - | '"' -> - if pos1 = len then - [name, Buffer.contents b] - else begin - let pos2 = pos1+1 in - match s.[pos1] with - | '"' -> - Buffer.add_char b '"'; - iter3 pos2 b name - | ',' -> - (name, Buffer.contents b) :: iter0 pos2 pos2 - | _ -> - raise (SyntaxError "Syntax error while expecting ',' after '\"'") - end - | c -> - Buffer.add_char b c; - iter3 pos1 b name - - in - iter0 0 0 -*) - let parse_args s = let args = Misc.split s ',' in let rec iter is_after args before after = @@ -190,7 +119,7 @@ let parse_args s = in iter false args [] [] -let setter f name options s = +let setter ppf f name options s = try let bool = match s with | "0" -> false @@ -199,26 +128,26 @@ let setter f name options s = in List.iter (fun b -> b := f bool) options with Not_found -> - Printf.eprintf "Warning: bad value for %S in OCAMLPARAM\n%!" name - -let set name options s = - setter (fun b -> b) name options s - -let clear name options s = - setter (fun b -> not b) name options s + Location.print_warning Location.none ppf + (Warnings.Bad_env_variable ("OCAMLPARAM", + Printf.sprintf "bad value for %s" name)) -let read_OCAMLPARAM position = +let read_OCAMLPARAM ppf position = try let s = Sys.getenv "OCAMLPARAM" in let (before, after) = try parse_args s with SyntaxError s -> - fatal (Printf.sprintf "Illegal syntax of OCAMLPARAM: %s" s) + Location.print_warning Location.none ppf + (Warnings.Bad_env_variable ("OCAMLPARAM", s)); + [],[] in + + let set name options s = setter ppf (fun b -> b) name options s in + let clear name options s = setter ppf (fun b -> not b) name options s in List.iter (fun (name, v) -> match name with - | "g" -> set "g" [ Clflags.debug ] v | "p" -> set "p" [ Clflags.gprofile ] v | "bin-annot" -> set "bin-annot" [ Clflags.binary_annotations ] v @@ -246,7 +175,6 @@ let read_OCAMLPARAM position = | "pp" -> preprocessor := Some v | "runtime-variant" -> runtime_variant := v - | "open" -> implicit_modules := Misc.split v ',' | "cc" -> c_compiler := Some v (* assembly sources *) @@ -266,8 +194,9 @@ let read_OCAMLPARAM position = | "inline" -> begin try inline_threshold := 8 * int_of_string v with _ -> - Printf.eprintf - "Warning: discarding non integer value of inline from OCAMLCOMPPARAM\n%!" + Location.print_warning Location.none ppf + (Warnings.Bad_env_variable ("OCAMLPARAM", + "non-integer parameter for \"inline\"")) end | "intf-suffix" -> Config.interface_suffix := v @@ -328,22 +257,21 @@ let read_OCAMLPARAM position = | _ -> Printf.eprintf - "Warning: discarding value of variable %S in OCAMLCOMPPARAM\n%!" + "Warning: discarding value of variable %S in OCAMLPARAM\n%!" name ) (match position with Before_args -> before | Before_compile | Before_link -> after) with Not_found -> () -let readenv position = +let readenv ppf position = last_include_dirs := []; last_ccopts := []; last_ppx := []; last_objfiles := []; - read_OCAMLPARAM position; + read_OCAMLPARAM ppf position; all_ccopts := !last_ccopts @ !first_ccopts; all_ppx := !last_ppx @ !first_ppx let get_objfiles () = List.rev (!last_objfiles @ !objfiles @ !first_objfiles) - diff --git a/driver/compenv.mli b/driver/compenv.mli index 6e0f5be046..d1d64393ac 100644 --- a/driver/compenv.mli +++ b/driver/compenv.mli @@ -2,9 +2,9 @@ (* *) (* OCaml *) (* *) -(* Fabrice Le Fessant, équipe Gallium, INRIA Rocquencourt *) +(* Fabrice Le Fessant, EPI Gallium, INRIA Paris-Rocquencourt *) (* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* 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. *) (* *) @@ -33,4 +33,4 @@ val get_objfiles : unit -> string list type readenv_position = Before_args | Before_compile | Before_link -val readenv : readenv_position -> unit +val readenv : Format.formatter -> readenv_position -> unit diff --git a/driver/compmisc.ml b/driver/compmisc.ml index 35c6b50d8f..e89018350d 100644 --- a/driver/compmisc.ml +++ b/driver/compmisc.ml @@ -2,9 +2,9 @@ (* *) (* OCaml *) (* *) -(* Fabrice Le Fessant, équipe Gallium, INRIA Rocquencourt *) +(* Fabrice Le Fessant, EPI Gallium, INRIA Paris-Rocquencourt *) (* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* 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. *) (* *) diff --git a/driver/compmisc.mli b/driver/compmisc.mli index 3ff3ae2aa7..032e9fe4aa 100644 --- a/driver/compmisc.mli +++ b/driver/compmisc.mli @@ -2,9 +2,9 @@ (* *) (* OCaml *) (* *) -(* Fabrice Le Fessant, équipe Gallium, INRIA Rocquencourt *) +(* Fabrice Le Fessant, EPI Gallium, INRIA Paris-Rocquencourt *) (* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* 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. *) (* *) diff --git a/driver/errors.ml b/driver/errors.ml index d45af05632..14a1a23cb4 100644 --- a/driver/errors.ml +++ b/driver/errors.ml @@ -75,7 +75,7 @@ let report_error ppf exn = fprintf ppf "I/O error: %s" msg | Warnings.Errors (n) -> Location.print_error_cur_file ppf; - fprintf ppf "Error-enabled warnings (%d occurrences)" n + fprintf ppf "Some fatal warnings were triggered (%d occurrences)" n | x -> fprintf ppf "@]"; raise x in fprintf ppf "@[%a@]@." report exn diff --git a/driver/main.ml b/driver/main.ml index 9fcb9a7db2..7d5e0929ff 100644 --- a/driver/main.ml +++ b/driver/main.ml @@ -58,11 +58,11 @@ let ppf = Format.err_formatter (* Error messages to standard error formatter *) let anonymous filename = - readenv Before_compile; process_file ppf filename;; + readenv ppf Before_compile; process_file ppf filename;; let impl filename = - readenv Before_compile; process_implementation_file ppf filename;; + readenv ppf Before_compile; process_implementation_file ppf filename;; let intf filename = - readenv Before_compile; process_interface_file ppf filename;; + readenv ppf Before_compile; process_interface_file ppf filename;; let show_config () = Config.print_config stdout; @@ -80,8 +80,8 @@ module Options = Main_args.Make_bytecomp_options (struct let _cc s = c_compiler := Some s let _cclib s = ccobjs := Misc.rev_split_words s @ !ccobjs let _ccopt s = first_ccopts := s :: !first_ccopts - let _config = show_config let _compat_32 = set bytecode_compatible_32 + let _config = show_config let _custom = set custom_runtime let _dllib s = dllibs := Misc.rev_split_words s @ !dllibs let _dllpath s = dllpaths := !dllpaths @ [s] @@ -139,9 +139,9 @@ end) let main () = try - readenv Before_args; + readenv ppf Before_args; Arg.parse Options.list anonymous usage; - readenv Before_link; + readenv ppf Before_link; if List.length (List.filter (fun x -> !x) [make_archive;make_package;compile_only;output_c_object]) diff --git a/driver/main_args.ml b/driver/main_args.ml index cf3f23977b..2753d7606e 100644 --- a/driver/main_args.ml +++ b/driver/main_args.ml @@ -15,7 +15,7 @@ let mk_a f = ;; let mk_absname f = - "-absname", Arg.Unit f, " Show absolute filenames in error messages" + "-absname", Arg.Unit f, " Show absolute filenames in error messages" ;; let mk_annot f = @@ -48,7 +48,8 @@ let mk_compact f = ;; let mk_compat_32 f = - "-compat-32", Arg.Unit f, " Check that generated bytecode executable can run on 32-bit platforms" + "-compat-32", Arg.Unit f, + " Check that generated bytecode can run on 32-bit platforms" ;; let mk_config f = @@ -225,10 +226,6 @@ let mk_principal f = "-principal", Arg.Unit f, " Check principality of type inference" ;; -let mk_short_paths f = - "-short-paths", Arg.Unit f, " Shorten paths in types" -;; - let mk_rectypes f = "-rectypes", Arg.Unit f, " Allow arbitrary recursive types" ;; @@ -242,6 +239,10 @@ let mk_S f = "-S", Arg.Unit f, " Keep intermediate assembly file" ;; +let mk_short_paths f = + "-short-paths", Arg.Unit f, " Shorten paths in types" +;; + let mk_stdin f = "-stdin", Arg.Unit f, " Read script from standard input" ;; @@ -280,24 +281,24 @@ let mk_v f = " Print compiler version and location of standard library and exit" ;; -let mk_version f = - "-version", Arg.Unit f, " Print version and exit" -;; - -let mk_vnum f = - "-vnum", Arg.Unit f, " Print version number and exit" -;; - let mk_verbose f = "-verbose", Arg.Unit f, " Print calls to external commands" ;; +let mk_version f = + "-version", Arg.Unit f, " Print version and exit" +;; + let mk_vmthread f = "-vmthread", Arg.Unit f, " Generate code that supports the threads library with VM-level\n\ \ scheduling" ;; +let mk_vnum f = + "-vnum", Arg.Unit f, " Print version number and exit" +;; + let mk_w f = "-w", Arg.String f, Printf.sprintf @@ -321,7 +322,7 @@ let mk_warn_error f = ;; let mk_warn_help f = - "-warn-help", Arg.Unit f, " Show description of warning numbers" + "-warn-help", Arg.Unit f, " Show description of warning numbers" ;; let mk_where f = @@ -430,8 +431,8 @@ module type Bytecomp_options = sig val _cc : string -> unit val _cclib : string -> unit val _ccopt : string -> unit - val _config : unit -> unit val _compat_32 : unit -> unit + val _config : unit -> unit val _custom : unit -> unit val _dllib : string -> unit val _dllpath : string -> unit @@ -456,9 +457,9 @@ module type Bytecomp_options = sig val _pp : string -> unit val _ppx : string -> unit val _principal : unit -> unit - val _short_paths : unit -> unit val _rectypes : unit -> unit val _runtime_variant : string -> unit + val _short_paths : unit -> unit val _strict_sequence : unit -> unit val _thread : unit -> unit val _vmthread : unit -> unit @@ -498,8 +499,8 @@ module type Bytetop_options = sig val _nostdlib : unit -> unit val _ppx : string -> unit val _principal : unit -> unit - val _short_paths : unit -> unit val _rectypes : unit -> unit + val _short_paths : unit -> unit val _stdin: unit -> unit val _strict_sequence : unit -> unit val _unsafe : unit -> unit @@ -554,18 +555,18 @@ module type Optcomp_options = sig val _pp : string -> unit val _ppx : string -> unit val _principal : unit -> unit - val _short_paths : unit -> unit val _rectypes : unit -> unit val _runtime_variant : string -> unit val _S : unit -> unit - val _strict_sequence : unit -> unit val _shared : unit -> unit + val _short_paths : unit -> unit + val _strict_sequence : unit -> unit val _thread : unit -> unit val _unsafe : unit -> unit val _v : unit -> unit + val _verbose : unit -> unit val _version : unit -> unit val _vnum : unit -> unit - val _verbose : unit -> unit val _w : string -> unit val _warn_error : string -> unit val _warn_help : unit -> unit @@ -610,9 +611,9 @@ module type Opttop_options = sig val _nostdlib : unit -> unit val _ppx : string -> unit val _principal : unit -> unit - val _short_paths : unit -> unit val _rectypes : unit -> unit val _S : unit -> unit + val _short_paths : unit -> unit val _stdin : unit -> unit val _strict_sequence : unit -> unit val _unsafe : unit -> unit @@ -660,8 +661,8 @@ struct mk_cc F._cc; mk_cclib F._cclib; mk_ccopt F._ccopt; - mk_config F._config; mk_compat_32 F._compat_32; + mk_config F._config; mk_custom F._custom; mk_dllib F._dllib; mk_dllpath F._dllpath; @@ -691,19 +692,19 @@ struct mk_pp F._pp; mk_ppx F._ppx; mk_principal F._principal; - mk_short_paths F._short_paths; mk_rectypes F._rectypes; mk_runtime_variant F._runtime_variant; + mk_short_paths F._short_paths; mk_strict_sequence F._strict_sequence; mk_thread F._thread; mk_unsafe F._unsafe; mk_use_runtime F._use_runtime; mk_use_runtime_2 F._use_runtime; mk_v F._v; - mk_version F._version; - mk_vnum F._vnum; mk_verbose F._verbose; + mk_version F._version; mk_vmthread F._vmthread; + mk_vnum F._vnum; mk_w F._w; mk_warn_error F._warn_error; mk_warn_help F._warn_help; @@ -736,8 +737,8 @@ struct mk_nostdlib F._nostdlib; mk_ppx F._ppx; mk_principal F._principal; - mk_short_paths F._short_paths; mk_rectypes F._rectypes; + mk_short_paths F._short_paths; mk_stdin F._stdin; mk_strict_sequence F._strict_sequence; mk_unsafe F._unsafe; @@ -796,18 +797,18 @@ struct mk_pp F._pp; mk_ppx F._ppx; mk_principal F._principal; - mk_short_paths F._short_paths; mk_rectypes F._rectypes; mk_runtime_variant F._runtime_variant; mk_S F._S; - mk_strict_sequence F._strict_sequence; mk_shared F._shared; + mk_short_paths F._short_paths; + mk_strict_sequence F._strict_sequence; mk_thread F._thread; mk_unsafe F._unsafe; mk_v F._v; + mk_verbose F._verbose; mk_version F._version; mk_vnum F._vnum; - mk_verbose F._verbose; mk_w F._w; mk_warn_error F._warn_error; mk_warn_help F._warn_help; @@ -854,9 +855,9 @@ module Make_opttop_options (F : Opttop_options) = struct mk_nostdlib F._nostdlib; mk_ppx F._ppx; mk_principal F._principal; - mk_short_paths F._short_paths; mk_rectypes F._rectypes; mk_S F._S; + mk_short_paths F._short_paths; mk_stdin F._stdin; mk_strict_sequence F._strict_sequence; mk_unsafe F._unsafe; diff --git a/driver/main_args.mli b/driver/main_args.mli index 657c30c8be..14a2dfd9af 100644 --- a/driver/main_args.mli +++ b/driver/main_args.mli @@ -20,8 +20,8 @@ module type Bytecomp_options = val _cc : string -> unit val _cclib : string -> unit val _ccopt : string -> unit - val _config : unit -> unit val _compat_32 : unit -> unit + val _config : unit -> unit val _custom : unit -> unit val _dllib : string -> unit val _dllpath : string -> unit @@ -46,9 +46,9 @@ module type Bytecomp_options = val _pp : string -> unit val _ppx : string -> unit val _principal : unit -> unit - val _short_paths : unit -> unit val _rectypes : unit -> unit val _runtime_variant : string -> unit + val _short_paths : unit -> unit val _strict_sequence : unit -> unit val _thread : unit -> unit val _vmthread : unit -> unit @@ -89,8 +89,8 @@ module type Bytetop_options = sig val _nostdlib : unit -> unit val _ppx : string -> unit val _principal : unit -> unit - val _short_paths : unit -> unit val _rectypes : unit -> unit + val _short_paths : unit -> unit val _stdin : unit -> unit val _strict_sequence : unit -> unit val _unsafe : unit -> unit @@ -145,18 +145,18 @@ module type Optcomp_options = sig val _pp : string -> unit val _ppx : string -> unit val _principal : unit -> unit - val _short_paths : unit -> unit val _rectypes : unit -> unit val _runtime_variant : string -> unit val _S : unit -> unit - val _strict_sequence : unit -> unit val _shared : unit -> unit + val _short_paths : unit -> unit + val _strict_sequence : unit -> unit val _thread : unit -> unit val _unsafe : unit -> unit val _v : unit -> unit + val _verbose : unit -> unit val _version : unit -> unit val _vnum : unit -> unit - val _verbose : unit -> unit val _w : string -> unit val _warn_error : string -> unit val _warn_help : unit -> unit @@ -201,9 +201,9 @@ module type Opttop_options = sig val _nostdlib : unit -> unit val _ppx : string -> unit val _principal : unit -> unit - val _short_paths : unit -> unit val _rectypes : unit -> unit val _S : unit -> unit + val _short_paths : unit -> unit val _stdin : unit -> unit val _strict_sequence : unit -> unit val _unsafe : unit -> unit diff --git a/driver/opterrors.ml b/driver/opterrors.ml index 38ed51bf9f..56660cdb19 100644 --- a/driver/opterrors.ml +++ b/driver/opterrors.ml @@ -77,7 +77,7 @@ let report_error ppf exn = fprintf ppf "I/O error: %s" msg | Warnings.Errors (n) -> Location.print_error_cur_file ppf; - fprintf ppf "Error-enabled warnings (%d occurrences)" n + fprintf ppf "Some fatal warnings were triggered (%d occurrences)" n | x -> fprintf ppf "@]"; raise x in fprintf ppf "@[%a@]@." report exn diff --git a/driver/optmain.ml b/driver/optmain.ml index 44bf4dd3cf..4d53d64a19 100644 --- a/driver/optmain.ml +++ b/driver/optmain.ml @@ -57,11 +57,11 @@ let ppf = Format.err_formatter (* Error messages to standard error formatter *) let anonymous filename = - readenv Before_compile; process_file ppf filename;; + readenv ppf Before_compile; process_file ppf filename;; let impl filename = - readenv Before_compile; process_implementation_file ppf filename;; + readenv ppf Before_compile; process_implementation_file ppf filename;; let intf filename = - readenv Before_compile; process_interface_file ppf filename;; + readenv ppf Before_compile; process_interface_file ppf filename;; let show_config () = Config.print_config stdout; @@ -106,9 +106,9 @@ module Options = Main_args.Make_optcomp_options (struct let _pp s = preprocessor := Some s let _ppx s = first_ppx := s :: !first_ppx let _principal = set principal - let _short_paths = clear real_paths let _rectypes = set recursive_types let _runtime_variant s = runtime_variant := s + let _short_paths = clear real_paths let _strict_sequence = set strict_sequence let _shared () = shared := true; dlcode := true let _S = set keep_asm_file @@ -151,9 +151,9 @@ let main () = native_code := true; let ppf = Format.err_formatter in try - readenv Before_args; + readenv ppf Before_args; Arg.parse (Arch.command_line_options @ Options.list) anonymous usage; - readenv Before_link; + readenv ppf Before_link; if List.length (List.filter (fun x -> !x) [make_package; make_archive; shared; diff --git a/emacs/.ignore b/emacs/.ignore index ea6381f91b..ba5f96cd34 100644 --- a/emacs/.ignore +++ b/emacs/.ignore @@ -1 +1,2 @@ ocamltags +*.elc diff --git a/emacs/caml.el b/emacs/caml.el index 939bd85f5d..4ff2fd8fbe 100644 --- a/emacs/caml.el +++ b/emacs/caml.el @@ -544,36 +544,41 @@ have caml-electric-indent on, which see.") (caml-show-imenu))) (run-hooks 'caml-mode-hook)) -(defun caml-set-compile-command () - "Hook to set compile-command locally, unless there is a Makefile or - a _build directory or a _tags file in the current directory." - (interactive) - (unless (or (null buffer-file-name) - (file-exists-p "makefile") - (file-exists-p "Makefile") - (file-exists-p "_build") - (file-exists-p "_tags")) - (let* ((filename (file-name-nondirectory buffer-file-name)) - (basename (file-name-sans-extension filename)) - (command nil)) - (cond - ((string-match ".*\\.mli\$" filename) - (setq command "ocamlc -c")) - ((string-match ".*\\.ml\$" filename) - (setq command "ocamlc -c") ; (concat "ocamlc -o " basename) - ) - ((string-match ".*\\.mll\$" filename) - (setq command "ocamllex")) - ((string-match ".*\\.mll\$" filename) - (setq command "ocamlyacc")) - ) - (if command - (progn - (make-local-variable 'compile-command) - (setq compile-command (concat command " " filename)))) - ))) -(add-hook 'caml-mode-hook 'caml-set-compile-command) +;; Disabled because it assumes make and does not play well with ocamlbuild. +;; See PR#4469 for details. + +;; (defun caml-set-compile-command () +;; "Hook to set compile-command locally, unless there is a Makefile or +;; a _build directory or a _tags file in the current directory." +;; (interactive) +;; (unless (or (null buffer-file-name) +;; (file-exists-p "makefile") +;; (file-exists-p "Makefile") +;; (file-exists-p "_build") +;; (file-exists-p "_tags")) +;; (let* ((filename (file-name-nondirectory buffer-file-name)) +;; (basename (file-name-sans-extension filename)) +;; (command nil)) +;; (cond +;; ((string-match ".*\\.mli\$" filename) +;; (setq command "ocamlc -c")) +;; ((string-match ".*\\.ml\$" filename) +;; (setq command "ocamlc -c") ; (concat "ocamlc -o " basename) +;; ) +;; ((string-match ".*\\.mll\$" filename) +;; (setq command "ocamllex")) +;; ((string-match ".*\\.mll\$" filename) +;; (setq command "ocamlyacc")) +;; ) +;; (if command +;; (progn +;; (make-local-variable 'compile-command) +;; (setq compile-command (concat command " " filename)))) +;; ))) + +;; (add-hook 'caml-mode-hook 'caml-set-compile-command) + ;;; Auxiliary function. Garrigue 96-11-01. diff --git a/lex/common.ml b/lex/common.ml index d52cbb94c4..36f8225e31 100644 --- a/lex/common.ml +++ b/lex/common.ml @@ -68,9 +68,9 @@ let copy_chars = "Win32" | "Cygwin" -> copy_chars_win32 | _ -> copy_chars_unix -let copy_chunk sourcefile ic oc trl loc add_parens = +let copy_chunk ic oc trl loc add_parens = if loc.start_pos < loc.end_pos || add_parens then begin - fprintf oc "# %d \"%s\"\n" loc.start_line sourcefile; + fprintf oc "# %d \"%s\"\n" loc.start_line loc.loc_file; if add_parens then begin for _i = 1 to loc.start_col - 1 do output_char oc ' ' done; output_char oc '('; @@ -122,7 +122,7 @@ let output_tag_access oc = function | Sum (a,i) -> fprintf oc "(%a + %d)" output_base_mem a i -let output_env sourcefile ic oc tr env = +let output_env ic oc tr env = let pref = ref "let" in match env with | [] -> () @@ -138,7 +138,7 @@ let output_env sourcefile ic oc tr env = List.iter (fun ((x,pos),v) -> fprintf oc "%s\n" !pref ; - copy_chunk sourcefile ic oc tr pos false ; + copy_chunk ic oc tr pos false ; begin match v with | Ident_string (o,nstart,nend) -> fprintf oc diff --git a/lex/common.mli b/lex/common.mli index f85baa01f8..c71febe8c6 100644 --- a/lex/common.mli +++ b/lex/common.mli @@ -14,13 +14,12 @@ type line_tracker;; val open_tracker : string -> out_channel -> line_tracker val close_tracker : line_tracker -> unit val copy_chunk : - string -> in_channel -> out_channel -> line_tracker -> Syntax.location -> bool -> unit val output_mem_access : out_channel -> int -> unit val output_memory_actions : string -> out_channel -> Lexgen.memory_action list -> unit val output_env : - string -> in_channel -> out_channel -> line_tracker -> + in_channel -> out_channel -> line_tracker -> (Lexgen.ident * Lexgen.ident_info) list -> unit val output_args : out_channel -> string list -> unit diff --git a/lex/lexer.mll b/lex/lexer.mll index 699c859924..8fc472e684 100644 --- a/lex/lexer.mll +++ b/lex/lexer.mll @@ -166,12 +166,13 @@ rule main = parse } | '{' { let p = Lexing.lexeme_end_p lexbuf in + let f = p.Lexing.pos_fname in let n1 = p.Lexing.pos_cnum and l1 = p.Lexing.pos_lnum and s1 = p.Lexing.pos_bol in brace_depth := 1; let n2 = handle_lexical_error action lexbuf in - Taction({start_pos = n1; end_pos = n2; + Taction({loc_file = f; start_pos = n1; end_pos = n2; start_line = l1; start_col = n1 - s1}) } | '=' { Tequal } | '|' { Tor } diff --git a/lex/output.ml b/lex/output.ml index ae1df0e1fd..d99f2f9010 100644 --- a/lex/output.ml +++ b/lex/output.ml @@ -92,8 +92,8 @@ let output_entry sourcefile ic oc oci e = (fun (num, env, loc) -> fprintf oc " | "; fprintf oc "%d ->\n" num; - output_env sourcefile ic oc oci env; - copy_chunk sourcefile ic oc oci loc true; + output_env ic oc oci env; + copy_chunk ic oc oci loc true; fprintf oc "\n") e.auto_actions; fprintf oc " | __ocaml_lex_state -> lexbuf.Lexing.refill_buff lexbuf; \ @@ -123,7 +123,7 @@ let output_lexdef sourcefile ic oc oci header tables entry_points trailer = Printf.printf "%d additional bytes used for bindings\n" size_groups ; flush stdout; if Array.length tables.tbl_trans > 0x8000 then raise Table_overflow; - copy_chunk sourcefile ic oc oci header false; + copy_chunk ic oc oci header false; output_tables oc tables; begin match entry_points with [] -> () @@ -134,4 +134,4 @@ let output_lexdef sourcefile ic oc oci header tables entry_points trailer = entries; output_string oc ";;\n\n"; end; - copy_chunk sourcefile ic oc oci trailer false + copy_chunk ic oc oci trailer false diff --git a/lex/outputbis.ml b/lex/outputbis.ml index 57851ab495..7e8cba6e17 100644 --- a/lex/outputbis.ml +++ b/lex/outputbis.ml @@ -165,8 +165,8 @@ let output_entry sourcefile ic oc tr e = (fun (num, env, loc) -> fprintf oc " | "; fprintf oc "%d ->\n" num; - output_env sourcefile ic oc tr env ; - copy_chunk sourcefile ic oc tr loc true; + output_env ic oc tr env ; + copy_chunk ic oc tr loc true; fprintf oc "\n") e.auto_actions; fprintf oc " | _ -> raise (Failure \"lexing: empty token\")\n\n\n" @@ -176,7 +176,7 @@ let output_entry sourcefile ic oc tr e = let output_lexdef sourcefile ic oc tr header entry_points transitions trailer = - copy_chunk sourcefile ic oc tr header false; + copy_chunk ic oc tr header false; output_automata oc transitions ; begin match entry_points with [] -> () @@ -187,4 +187,4 @@ let output_lexdef sourcefile ic oc tr header entry_points transitions trailer = entries; output_string oc ";;\n\n"; end; - copy_chunk sourcefile ic oc tr trailer false + copy_chunk ic oc tr trailer false diff --git a/lex/parser.mly b/lex/parser.mly index fe8260d766..b42cced949 100644 --- a/lex/parser.mly +++ b/lex/parser.mly @@ -74,7 +74,8 @@ header: Taction { $1 } | /*epsilon*/ - { { start_pos = 0; end_pos = 0; start_line = 1; start_col = 0 } } + { { loc_file = ""; start_pos = 0; end_pos = 0; start_line = 1; + start_col = 0 } } ; named_regexps: named_regexps Tlet Tident Tequal regexp @@ -162,6 +163,7 @@ regexp: {let p1 = Parsing.rhs_start_pos 3 and p2 = Parsing.rhs_end_pos 3 in let p = { + loc_file = p1.Lexing.pos_fname ; start_pos = p1.Lexing.pos_cnum ; end_pos = p2.Lexing.pos_cnum ; start_line = p1.Lexing.pos_lnum ; diff --git a/lex/syntax.ml b/lex/syntax.ml index afa6ac3b01..72f101e253 100644 --- a/lex/syntax.ml +++ b/lex/syntax.ml @@ -15,11 +15,13 @@ (* The shallow abstract syntax *) -type location = - { start_pos: int; - end_pos: int; - start_line: int; - start_col: int } +type location = { + loc_file : string; + start_pos : int; + end_pos : int; + start_line : int; + start_col : int; +} type regular_expression = Epsilon diff --git a/lex/syntax.mli b/lex/syntax.mli index d186f12c39..55c3c117a1 100644 --- a/lex/syntax.mli +++ b/lex/syntax.mli @@ -12,11 +12,13 @@ (* The shallow abstract syntax *) -type location = - { start_pos: int; - end_pos: int; - start_line: int; - start_col: int } +type location = { + loc_file : string; + start_pos : int; + end_pos : int; + start_line : int; + start_col : int; +} type regular_expression = Epsilon diff --git a/man/ocaml.m b/man/ocaml.m index c3dff4475c..39baf7b71a 100644 --- a/man/ocaml.m +++ b/man/ocaml.m @@ -64,6 +64,9 @@ exits after the execution of the last phrase. The following command-line options are recognized by .BR ocaml (1). .TP +.B \-absname +Show absolute filenames in error messages. +.TP .BI \-I \ directory Add the given directory to the list of directories searched for source and compiled files. By default, the current directory is @@ -100,6 +103,12 @@ in the user's home directory. Labels are not ignored in types, labels may be used in applications, and labelled parameters can be given in any order. This is the default. .TP +.B \-no\-app\-funct +Deactivates the applicative behaviour of functors. With this option, +each functor application generates new types in its result and +applying the same functor twice to the same argument yields two +incompatible structures. +.TP .B \-noassert Do not compile assertion checks. Note that the special form .B assert\ false @@ -124,6 +133,12 @@ window. Do not include the standard library directory in the list of directories searched for source and compiled files. .TP +.BI \-ppx \ command +After parsing, pipe the abstract syntax tree through the preprocessor +.IR command . +The format of the input and ouput of the preprocessor +are not yet documented. +.TP .B \-principal Check information path during type-checking, to make sure that all types are derived in a principal way. When using labelled arguments @@ -142,6 +157,18 @@ Allow arbitrary recursive types during type-checking. By default, only recursive types where the recursion goes through an object type are supported. .TP +.B \-short\-paths +When a type is visible under several module-paths, use the shortest +one when printing the type's name in inferred interfaces and error and +warning messages. +.TP +.B \-stdin +Read the standard input as a script file rather than starting an +interactive session. +.TP +.B \-strict\-sequence +Force the left-hand part of each sequence to have type unit. +.TP .B \-unsafe Turn bound checking off on array and string accesses (the .BR v.(i) and s.[i] @@ -166,9 +193,9 @@ for the syntax of the argument. .TP .BI \-warn-error \ warning-list -Treat as errors the warnings described by the argument +Mark as fatal the warnings described by the argument .IR warning\-list . -Note that a warning is not triggered (and not treated as error) if +Note that a warning is not triggered (and does not trigger an error) if it is disabled by the .B \-w option. See @@ -177,6 +204,14 @@ for the syntax of the .I warning\-list argument. .TP +.B \-warn\-help +Show the description of all available warning numbers. +.TP +.BI \- \ file +Use +.I file +as a script file name, even when it starts with a hyphen (-). +.TP .BR \-help \ or \ \-\-help Display a short usage summary and exit. diff --git a/man/ocamlc.m b/man/ocamlc.m index c5c8c435b4..fb3902a888 100644 --- a/man/ocamlc.m +++ b/man/ocamlc.m @@ -209,10 +209,19 @@ file can be used with the emacs commands given in .B emacs/caml\-types.el to display types and other annotations interactively. .TP -.B \-dtypes -Has been deprecated. Please use -.B \-annot -instead. +.B \-bin\-annot +Dump detailed information about the compilation (types, bindings, +tail-calls, etc) in binary format. The information for file +.IR src .ml +is put into file +.IR src .cmt. +In case of a type error, dump +all the information inferred by the type-checker before the error. +The annotation files produced by +.B \-bin\-annot +contain more information +and are much more compact than the files produced by +.BR \-annot . .TP .B \-c Compile only. Suppress the linking phase of the @@ -234,8 +243,10 @@ option to the C linker when linking in "custom runtime" mode (see the .B \-custom option). This causes the given C library to be linked with the program. .TP -.B \-ccopt -Pass the given option to the C compiler and linker, when linking in +.BI \-ccopt \ option +Pass the given +.I option +to the C compiler and linker, when linking in "custom runtime" mode (see the .B \-custom option). For instance, @@ -244,6 +255,11 @@ causes the C linker to search for C libraries in directory .IR dir . .TP +.B \-compat\-32 +Check that the generated bytecode executable can run on 32-bit +platforms and signal an error if it cannot. This is useful when +compiling bytecode on a 64-bit machine. +.TP .B \-config Print the version number of .BR ocamlc (1) @@ -293,6 +309,11 @@ executable file, where .BR ocamlrun (1) can find it and use it. .TP +.BI \-for\-pack \ ident +This option is accepted for compatibility with +.BR ocamlopt (1) +; it does nothing. +.TP .B \-g Add debugging information while compiling and linking. This option is required in order to be able to debug the program with @@ -370,6 +391,12 @@ bytecode executables produced with the option .B ocamlc\ \-use\-runtime .IR runtime-name . .TP +.B \-no\-app\-funct +Deactivates the applicative behaviour of functors. With this option, +each functor application generates new types in its result and +applying the same functor twice to the same argument yields two +incompatible structures. +.TP .B \-noassert Do not compile assertion checks. Note that the special form .B assert\ false @@ -390,6 +417,12 @@ and pass the correct C libraries and options on the command line. Ignore non-optional labels in types. Labels cannot be used in applications, and parameter order becomes strict. .TP +.B \-nostdlib +Do not include the standard library directory in the list of +directories searched for compiled interfaces (see option +.B \-I +). +.TP .BI \-o \ exec\-file Specify the name of the output file produced by the linker. The default output name is @@ -443,8 +476,10 @@ extension .ppi for an interface (.mli) file and .ppo for an implementation (.ml) file. .TP .BI \-ppx \ command -Pipe abstract syntax tree through preprocessor +After parsing, pipe the abstract syntax tree through the preprocessor .IR command . +The format of the input and ouput of the preprocessor +are not yet documented. .TP .B \-principal Check information path during type-checking, to make sure that all @@ -475,8 +510,13 @@ then the .B d suffix is supported and gives a debug version of the runtime. .TP +.B \-short\-paths +When a type is visible under several module-paths, use the shortest +one when printing the type's name in inferred interfaces and error and +warning messages. +.TP .B \-strict\-sequence -The left-hand part of a sequence must have type unit. +Force the left-hand part of each sequence to have type unit. .TP .B \-thread Compile or link multithreaded programs, in combination with the @@ -510,30 +550,29 @@ invocations of the C compiler and linker in .B \-custom mode. Useful to debug C library problems. .TP -.BR \-vnum \ or\ \-version -Print the version number of the compiler in short form (e.g. "3.11.0"), -then exit. -.TP .B \-vmthread Compile or link multithreaded programs, in combination with the VM-level threads library described in .IR The\ OCaml\ user's\ manual . .TP +.BR \-vnum \ or\ \-version +Print the version number of the compiler in short form (e.g. "3.11.0"), +then exit. +.TP .BI \-w \ warning\-list -Enable, disable, or mark as errors the warnings specified by the argument +Enable, disable, or mark as fatal the warnings specified by the argument .IR warning\-list . Each warning can be .IR enabled \ or\ disabled , and each warning can be -.I marked -(as error) or -.IR unmarked . +.IR fatal or +.IR non-fatal . If a warning is disabled, it isn't displayed and doesn't affect -compilation in any way (even if it is marked). If a warning is enabled, +compilation in any way (even if it is fatal). If a warning is enabled, it is displayed normally by the compiler whenever the source code -triggers it. If it is enabled and marked, the compiler will stop with -an error after displaying the warnings if the source code triggers it. +triggers it. If it is enabled and fatal, the compiler will also stop +with an error after displaying it. The .I warning\-list @@ -549,7 +588,7 @@ between them. A warning specifier is one of the following: .IR num . .BI @ num -\ \ Enable and mark warning number +\ \ Enable and mark as fatal warning number .IR num . .BI + num1 .. num2 @@ -567,7 +606,7 @@ and (inclusive). .BI @ num1 .. num2 -\ \ Enable and mark all warnings between +\ \ Enable and mark as fatal all warnings between .I num1 and .I num2 @@ -584,7 +623,7 @@ The letter may be uppercase or lowercase. The letter may be uppercase or lowercase. .BI @ letter -\ \ Enable and mark the set of warnings corresponding to +\ \ Enable and mark as fatal the set of warnings corresponding to .IR letter . The letter may be uppercase or lowercase. @@ -605,7 +644,7 @@ The warning numbers are as follows. \ \ \ Suspicious-looking end-of-comment mark. 3 -\ \ \ Deprecated syntax. +\ \ \ Deprecated feature. 4 \ \ \ Fragile pattern matching: matching that will remain @@ -699,6 +738,55 @@ pattern. \ \ A non-escaped end-of-line was found in a string constant. This may cause portability problems between Unix and Windows. +30 +\ \ Two labels or constructors of the same name are defined in two +mutually recursive types. + +31 +\ \ A module is linked twice in the same executable. + +32 +\ \ Unused value declaration. + +33 +\ \ Unused open statement. + +34 +\ \ Unused type declaration. + +35 +\ \ Unused for-loop index. + +36 +\ \ Unused ancestor variable. + +37 +\ \ Unused constructor. + +38 +\ \ Unused exception constructor. + +39 +\ \ Unused rec flag. + +40 +\ \ Constructor or label name used out of scope. + +41 +\ \ Ambiguous constructor or label name. + +42 +\ \ Disambiguated constructor or label name. + +43 +\ \ Nonoptional label applied as optional. + +44 +\ \ Open statement shadows an already defined identifier. + +45 +\ \ Open statement shadows an already defined label or constructor. + The letters stand for the following sets of warnings. Any letter not mentioned here corresponds to the empty set. @@ -718,7 +806,7 @@ mentioned here corresponds to the empty set. \ 5 .B K -\ 32, 33, 34, 35, 36, 37 +\ 32, 33, 34, 35, 36, 37, 38, 39 .B L \ 6 @@ -752,7 +840,7 @@ mentioned here corresponds to the empty set. .IP The default setting is -.BR \-w\ +a\-4\-6\-9\-27\-29\-32..39\-42\-44 . +.BR \-w\ +a\-4\-6\-7\-9\-27\-29\-32..39\-41..42\-44\-45 . Note that warnings .BR 5 \ and \ 10 are not always triggered, depending on the internals of the type checker. @@ -768,11 +856,11 @@ the .B \-w option: a .B + -sign (or an uppercase letter) turns the corresponding warnings into errors, a +sign (or an uppercase letter) marks the corresponding warnings as fatal, a .B \- -sign (or a lowercase letter) turns them back into warnings, and a +sign (or a lowercase letter) turns them back into non-fatal warnings, and a .B @ -sign both enables and marks the corresponding warnings. +sign both enables and marks as fatal the corresponding warnings. Note: it is not recommended to use the .B \-warn\-error @@ -781,8 +869,10 @@ compiling your program with later versions of OCaml when they add new warnings. The default setting is -.B \-warn\-error\ -a -(none of the warnings is treated as an error). +.B \-warn\-error\ -a (all warnings are non-fatal). +.TP +.B \-warn\-help +Show the description of all available warning numbers. .TP .B \-where Print the location of the standard library, then exit. diff --git a/man/ocamlopt.m b/man/ocamlopt.m index 7e586429b7..998651bbb1 100644 --- a/man/ocamlopt.m +++ b/man/ocamlopt.m @@ -171,10 +171,19 @@ file can be used with the emacs commands given in .B emacs/caml\-types.el to display types and other annotations interactively. .TP -.B \-dtypes -Has been deprecated. Please use -.BI \-annot -instead. +.B \-bin\-annot +Dump detailed information about the compilation (types, bindings, +tail-calls, etc) in binary format. The information for file +.IR src .ml +is put into file +.IR src .cmt. +In case of a type error, dump +all the information inferred by the type-checker before the error. +The annotation files produced by +.B \-bin\-annot +contain more information +and are much more compact than the files produced by +.BR \-annot . .TP .B \-c Compile only. Suppress the linking phase of the @@ -254,6 +263,11 @@ adds the subdirectory .B labltk of the standard library to the search path. .TP +.BI \-impl \ filename +Compile the file +.I filename +as an implementation file, even if its extension is not .ml. +.TP .BI \-inline \ n Set aggressiveness of inlining to .IR n , @@ -297,6 +311,12 @@ flag forces all subsequent links of programs involving that library to link all the modules contained in the library. .TP +.B \-no\-app\-funct +Deactivates the applicative behaviour of functors. With this option, +each functor application generates new types in its result and +applying the same functor twice to the same argument yields two +incompatible structures. +.TP .B \-noassert Do not compile assertion checks. Note that the special form .B assert\ false @@ -409,8 +429,10 @@ an intermediate file, which is compiled. If there are no compilation errors, the intermediate file is deleted afterwards. .TP .BI \-ppx \ command -Pipe abstract syntax tree through preprocessor +After parsing, pipe the abstract syntax tree through the preprocessor .IR command . +The format of the input and ouput of the preprocessor +are not yet documented. .TP .B \-principal Check information path during type-checking, to make sure that all @@ -460,6 +482,11 @@ flag. Some constraints might also apply to the way the extra native objects have been compiled (under Linux AMD 64, they must contain only position-independent code). .TP +.B \-short\-paths +When a type is visible under several module-paths, use the shortest +one when printing the type's name in inferred interfaces and error and +warning messages. +.TP .B \-strict\-sequence The left-hand part of a sequence must have type unit. .TP @@ -497,7 +524,7 @@ Print the version number of the compiler in short form (e.g. "3.11.0"), then exit. .TP .BI \-w \ warning\-list -Enable, disable, or mark as errors the warnings specified by the argument +Enable, disable, or mark as fatal the warnings specified by the argument .IR warning\-list . See .BR ocamlc (1) @@ -505,7 +532,7 @@ for the syntax of .IR warning-list . .TP .BI \-warn\-error \ warning\-list -Mark as errors the warnings specified in the argument +Mark as fatal the warnings specified in the argument .IR warning\-list . The compiler will stop with an error when one of these warnings is emitted. The @@ -515,11 +542,11 @@ the .B \-w option: a .B + -sign (or an uppercase letter) turns the corresponding warnings into errors, a +sign (or an uppercase letter) marks the corresponding warnings as fatal, a .B \- -sign (or a lowercase letter) turns them back into warnings, and a +sign (or a lowercase letter) turns them back into non-fatal warnings, and a .B @ -sign both enables and marks the corresponding warnings. +sign both enables and marks as fatal the corresponding warnings. Note: it is not recommended to use the .B \-warn\-error @@ -528,8 +555,11 @@ compiling your program with later versions of OCaml when they add new warnings. The default setting is -.B \-warn\-error\ -a -(none of the warnings is treated as an error). +.B \-warn\-error\ -a (all warnings are non-fatal). +.TP +.B \-warn\-help +Show the description of all available warning numbers. +.TP .TP .B \-where Print the location of the standard library, then exit. diff --git a/ocamldoc/.depend b/ocamldoc/.depend index 19c55832e5..5e270a68e5 100644 --- a/ocamldoc/.depend +++ b/ocamldoc/.depend @@ -11,26 +11,26 @@ odoc_analyse.cmo: ../utils/warnings.cmi ../typing/typetexp.cmi \ ../typing/types.cmi ../typing/typemod.cmi ../typing/typedtree.cmi \ ../typing/typedecl.cmi ../typing/typecore.cmi ../typing/typeclass.cmi \ ../bytecomp/translcore.cmi ../bytecomp/translclass.cmi \ - ../parsing/syntaxerr.cmi ../parsing/parse.cmi odoc_types.cmi \ - odoc_text.cmi odoc_sig.cmi odoc_module.cmo odoc_misc.cmi \ + ../parsing/syntaxerr.cmi ../driver/pparse.cmi ../parsing/parse.cmi \ + odoc_types.cmi odoc_text.cmi odoc_sig.cmi odoc_module.cmo odoc_misc.cmi \ odoc_messages.cmo odoc_merge.cmi odoc_global.cmi odoc_dep.cmo \ odoc_cross.cmi odoc_comments.cmi odoc_class.cmo odoc_ast.cmi \ ../utils/misc.cmi ../parsing/location.cmi ../parsing/lexer.cmi \ ../typing/includemod.cmi ../typing/env.cmi ../typing/ctype.cmi \ ../utils/config.cmi ../typing/cmi_format.cmi ../utils/clflags.cmi \ - ../utils/ccomp.cmi odoc_analyse.cmi + odoc_analyse.cmi odoc_analyse.cmx : ../utils/warnings.cmx ../typing/typetexp.cmx \ ../typing/types.cmx ../typing/typemod.cmx ../typing/typedtree.cmx \ ../typing/typedecl.cmx ../typing/typecore.cmx ../typing/typeclass.cmx \ ../bytecomp/translcore.cmx ../bytecomp/translclass.cmx \ - ../parsing/syntaxerr.cmx ../parsing/parse.cmx odoc_types.cmx \ - odoc_text.cmx odoc_sig.cmx odoc_module.cmx odoc_misc.cmx \ + ../parsing/syntaxerr.cmx ../driver/pparse.cmx ../parsing/parse.cmx \ + odoc_types.cmx odoc_text.cmx odoc_sig.cmx odoc_module.cmx odoc_misc.cmx \ odoc_messages.cmx odoc_merge.cmx odoc_global.cmx odoc_dep.cmx \ odoc_cross.cmx odoc_comments.cmx odoc_class.cmx odoc_ast.cmx \ ../utils/misc.cmx ../parsing/location.cmx ../parsing/lexer.cmx \ ../typing/includemod.cmx ../typing/env.cmx ../typing/ctype.cmx \ ../utils/config.cmx ../typing/cmi_format.cmx ../utils/clflags.cmx \ - ../utils/ccomp.cmx odoc_analyse.cmi + odoc_analyse.cmi odoc_args.cmo : odoc_types.cmi odoc_texi.cmo odoc_messages.cmo odoc_man.cmo \ odoc_latex.cmo odoc_html.cmo odoc_global.cmi odoc_gen.cmi odoc_dot.cmo \ odoc_config.cmi ../utils/misc.cmi ../utils/config.cmi odoc_args.cmi diff --git a/ocamldoc/odoc_analyse.ml b/ocamldoc/odoc_analyse.ml index 572e94fff9..19621cb5e1 100644 --- a/ocamldoc/odoc_analyse.ml +++ b/ocamldoc/odoc_analyse.ml @@ -146,7 +146,7 @@ let process_error exn = Location.print_error ppf loc; Translclass.report_error ppf err | Warnings.Errors (n) -> Location.print_error_cur_file ppf; - fprintf ppf "Error-enabled warnings (%d occurrences)" n + fprintf ppf "Some fatal warnings were triggered (%d occurrences)" n | x -> fprintf ppf "@]"; fprintf ppf diff --git a/ocamldoc/odoc_comments.ml b/ocamldoc/odoc_comments.ml index ce96f2ad92..c39cb51bf9 100644 --- a/ocamldoc/odoc_comments.ml +++ b/ocamldoc/odoc_comments.ml @@ -90,7 +90,7 @@ module Info_retriever = with Failure s -> incr Odoc_global.errors ; - prerr_endline (file^" : "^s^"\n"); + Printf.eprintf "File %S, line %d:\n%s\n%!" file (!Odoc_lexer.line_number + 1) s; (0, None) | Odoc_text.Text_syntax (l, c, s) -> incr Odoc_global.errors ; diff --git a/ocamldoc/odoc_html.ml b/ocamldoc/odoc_html.ml index e2e84644dd..36cb39d0a9 100644 --- a/ocamldoc/odoc_html.ml +++ b/ocamldoc/odoc_html.ml @@ -669,13 +669,13 @@ class virtual info = @param indent can be specified not to use the style of info comments; default is [true]. *) - method html_of_info ?(indent=true) b info_opt = + method html_of_info ?(cls="") ?(indent=true) b info_opt = match info_opt with None -> () | Some info -> let module M = Odoc_info in - if indent then bs b "<div class=\"info\">\n"; + if indent then bs b ("<div class=\"info "^cls^"\">\n"); ( match info.M.i_deprecated with None -> () @@ -1392,7 +1392,7 @@ class html = (** Print html code for a value. *) method html_of_value b v = Odoc_info.reset_type_names (); - bs b "<pre>" ; + bs b "\n<pre>" ; bp b "<span id=\"%s\">" (Naming.value_target v); bs b (self#keyword "val"); bs b " "; @@ -1419,7 +1419,7 @@ class html = (** Print html code for an exception. *) method html_of_exception b e = Odoc_info.reset_type_names (); - bs b "<pre>"; + bs b "\n<pre>"; bp b "<span id=\"%s\">" (Naming.exception_target e); bs b (self#keyword "exception"); bs b " "; @@ -1454,12 +1454,12 @@ class html = let father = Name.father t.ty_name in bs b (match t.ty_manifest, t.ty_kind with - None, Type_abstract -> "<pre>" + None, Type_abstract -> "\n<pre>" | None, Type_variant _ - | None, Type_record _ -> "<pre><code>" - | Some _, Type_abstract -> "<pre>" + | None, Type_record _ -> "\n<pre><code>" + | Some _, Type_abstract -> "\n<pre>" | Some _, Type_variant _ - | Some _, Type_record _ -> "<pre>" + | Some _, Type_record _ -> "\n<pre>" ); bp b "<span id=\"%s\">" (Naming.type_target t); bs b ((self#keyword "type")^" "); @@ -1552,7 +1552,7 @@ class html = bs b "</td>\n<td align=\"left\" valign=\"top\" >\n"; bs b "<code>"; if r.rf_mutable then bs b (self#keyword "mutable ") ; - bp b "<span id=\"%s\">%s</span> :" + bp b "<span id=\"%s\">%s</span> : " (Naming.recfield_target t r) r.rf_name; self#html_of_type_expr b father r.rf_type; @@ -1582,7 +1582,7 @@ class html = (** Print html code for a class attribute. *) method html_of_attribute b a = let module_name = Name.father (Name.father a.att_value.val_name) in - bs b "<pre>" ; + bs b "\n<pre>" ; bp b "<span id=\"%s\">" (Naming.attribute_target a); bs b (self#keyword "val"); bs b " "; @@ -1614,7 +1614,7 @@ class html = (** Print html code for a class method. *) method html_of_method b m = let module_name = Name.father (Name.father m.met_value.val_name) in - bs b "<pre>"; + bs b "\n<pre>"; (* html mark *) bp b "<span id=\"%s\">" (Naming.method_target m); bs b ((self#keyword "method")^" "); @@ -1758,7 +1758,7 @@ class html = method html_of_module b ?(info=true) ?(complete=true) ?(with_link=true) m = let (html_file, _) = Naming.html_files m.m_name in let father = Name.father m.m_name in - bs b "<pre>"; + bs b "\n<pre>"; bs b ((self#keyword "module")^" "); ( if with_link then @@ -1777,7 +1777,7 @@ class html = if info then ( if complete then - self#html_of_info ~indent: true + self#html_of_info ~cls: "module top" ~indent: true else self#html_of_info_first_sentence ) b m.m_info @@ -1788,7 +1788,7 @@ class html = method html_of_modtype b ?(info=true) ?(complete=true) ?(with_link=true) mt = let (html_file, _) = Naming.html_files mt.mt_name in let father = Name.father mt.mt_name in - bs b "<pre>"; + bs b "\n<pre>"; bs b ((self#keyword "module type")^" "); ( if with_link then @@ -1806,7 +1806,7 @@ class html = if info then ( if complete then - self#html_of_info ~indent: true + self#html_of_info ~cls: "modtype top" ~indent: true else self#html_of_info_first_sentence ) b mt.mt_info @@ -1815,7 +1815,7 @@ class html = (** Print html code for an included module. *) method html_of_included_module b im = - bs b "<pre>"; + bs b "\n<pre>"; bs b ((self#keyword "include")^" "); ( match im.im_module with @@ -1926,7 +1926,7 @@ class html = let father = Name.father c.cl_name in Odoc_info.reset_type_names (); let (html_file, _) = Naming.html_files c.cl_name in - bs b "<pre>"; + bs b "\n<pre>"; (* we add a html id, the same as for a type so we can go directly here when the class name is used as a type name *) bp b "<span name=\"%s\">" @@ -1963,7 +1963,7 @@ class html = print_DEBUG "html#html_of_class : info" ; ( if complete then - self#html_of_info ~indent: true + self#html_of_info ~cls: "class top" ~indent: true else self#html_of_info_first_sentence ) b c.cl_info @@ -1973,7 +1973,7 @@ class html = Odoc_info.reset_type_names (); let father = Name.father ct.clt_name in let (html_file, _) = Naming.html_files ct.clt_name in - bs b "<pre>"; + bs b "\n<pre>"; (* we add a html id, the same as for a type so we can go directly here when the class type name is used as a type name *) bp b "<span id=\"%s\">" @@ -2006,7 +2006,7 @@ class html = bs b "</pre>"; ( if complete then - self#html_of_info ~indent: true + self#html_of_info ~cls: "classtype top" ~indent: true else self#html_of_info_first_sentence ) b ct.clt_info diff --git a/ocamldoc/odoc_lexer.mll b/ocamldoc/odoc_lexer.mll index cabcfc2d09..998d31bd16 100644 --- a/ocamldoc/odoc_lexer.mll +++ b/ocamldoc/odoc_lexer.mll @@ -293,6 +293,10 @@ and elements = parse incr Odoc_comments_global.nb_chars; print_DEBUG2 "newline"; elements lexbuf } + | "@" + { + raise (Failure (Odoc_messages.should_escape_at_sign)) + } | "@"lowercase+ { @@ -339,6 +343,10 @@ and elements = parse { EOF } + | _ { + let s = Lexing.lexeme lexbuf in + failwith ("Unexpected character '"^s^"'") + } and simple = parse diff --git a/ocamldoc/odoc_messages.ml b/ocamldoc/odoc_messages.ml index 1d80e88b3d..2d6327bba7 100644 --- a/ocamldoc/odoc_messages.ml +++ b/ocamldoc/odoc_messages.ml @@ -246,6 +246,7 @@ let file_not_found_in_paths paths name = (String.concat "\n" paths) let tag_not_handled tag = "Tag @"^tag^" not handled by this generator" +let should_escape_at_sign = "The character @ has a special meaning in ocamldoc comments, for commands such as @raise or @since. If you want to write a single @, you must escape it as \\@." let bad_tree = "Incorrect tree structure." let not_a_valid_tag s = s^" is not a valid tag." let fun_without_param f = "Function "^f^" has no parameter.";; diff --git a/otherlibs/Makefile.shared b/otherlibs/Makefile.shared index 26416eac3c..4e8092f9ba 100644 --- a/otherlibs/Makefile.shared +++ b/otherlibs/Makefile.shared @@ -43,10 +43,12 @@ all: lib$(CLIBNAME).$(A) $(LIBNAME).cma $(CMIFILES) allopt: lib$(CLIBNAME).$(A) $(LIBNAME).cmxa $(LIBNAME).$(CMXS) $(CMIFILES) $(LIBNAME).cma: $(CAMLOBJS) - $(MKLIB) -o $(LIBNAME) -oc $(CLIBNAME) -ocamlc '$(CAMLC)' -linkall $(CAMLOBJS) $(LINKOPTS) + $(MKLIB) -o $(LIBNAME) -oc $(CLIBNAME) -ocamlc '$(CAMLC)' -linkall \ + $(CAMLOBJS) $(LINKOPTS) $(LIBNAME).cmxa: $(CAMLOBJS_NAT) - $(MKLIB) -o $(LIBNAME) -oc $(CLIBNAME) -ocamlopt '$(CAMLOPT)' -linkall $(CAMLOBJS_NAT) $(LINKOPTS) + $(MKLIB) -o $(LIBNAME) -oc $(CLIBNAME) -ocamlopt '$(CAMLOPT)' -linkall \ + $(CAMLOBJS_NAT) $(LINKOPTS) $(LIBNAME).cmxs: $(LIBNAME).cmxa lib$(CLIBNAME).$(A) $(CAMLOPT) -shared -o $(LIBNAME).cmxs -I . $(LIBNAME).cmxa diff --git a/otherlibs/bigarray/bigarray.ml b/otherlibs/bigarray/bigarray.ml index 4cadfd9173..0aea1f4cba 100644 --- a/otherlibs/bigarray/bigarray.ml +++ b/otherlibs/bigarray/bigarray.ml @@ -94,7 +94,7 @@ module Genarray = struct external fill: ('a, 'b, 'c) t -> 'a -> unit = "caml_ba_fill" external map_internal: Unix.file_descr -> ('a, 'b) kind -> 'c layout -> bool -> int array -> int64 -> ('a, 'b, 'c) t - = "caml_ba_map_file_bytecode" "caml_ba_map_file" + = "caml_ba_map_file_bytecode" "caml_ba_map_file" let map_file fd ?(pos = 0L) kind layout shared dims = map_internal fd kind layout shared dims pos end @@ -106,7 +106,8 @@ module Array1 = struct external get: ('a, 'b, 'c) t -> int -> 'a = "%caml_ba_ref_1" external set: ('a, 'b, 'c) t -> int -> 'a -> unit = "%caml_ba_set_1" external unsafe_get: ('a, 'b, 'c) t -> int -> 'a = "%caml_ba_unsafe_ref_1" - external unsafe_set: ('a, 'b, 'c) t -> int -> 'a -> unit = "%caml_ba_unsafe_set_1" + external unsafe_set: ('a, 'b, 'c) t -> int -> 'a -> unit + = "%caml_ba_unsafe_set_1" external dim: ('a, 'b, 'c) t -> int = "%caml_ba_dim_1" external kind: ('a, 'b, 'c) t -> ('a, 'b) kind = "caml_ba_kind" external layout: ('a, 'b, 'c) t -> 'c layout = "caml_ba_layout" @@ -128,17 +129,19 @@ module Array2 = struct Genarray.create kind layout [|dim1; dim2|] external get: ('a, 'b, 'c) t -> int -> int -> 'a = "%caml_ba_ref_2" external set: ('a, 'b, 'c) t -> int -> int -> 'a -> unit = "%caml_ba_set_2" - external unsafe_get: ('a, 'b, 'c) t -> int -> int -> 'a = "%caml_ba_unsafe_ref_2" - external unsafe_set: ('a, 'b, 'c) t -> int -> int -> 'a -> unit = "%caml_ba_unsafe_set_2" + external unsafe_get: ('a, 'b, 'c) t -> int -> int -> 'a + = "%caml_ba_unsafe_ref_2" + external unsafe_set: ('a, 'b, 'c) t -> int -> int -> 'a -> unit + = "%caml_ba_unsafe_set_2" external dim1: ('a, 'b, 'c) t -> int = "%caml_ba_dim_1" external dim2: ('a, 'b, 'c) t -> int = "%caml_ba_dim_2" external kind: ('a, 'b, 'c) t -> ('a, 'b) kind = "caml_ba_kind" external layout: ('a, 'b, 'c) t -> 'c layout = "caml_ba_layout" external sub_left: ('a, 'b, c_layout) t -> int -> int -> ('a, 'b, c_layout) t - = "caml_ba_sub" + = "caml_ba_sub" external sub_right: ('a, 'b, fortran_layout) t -> int -> int -> ('a, 'b, fortran_layout) t - = "caml_ba_sub" + = "caml_ba_sub" let slice_left a n = Genarray.slice_left a [|n|] let slice_right a n = Genarray.slice_right a [|n|] external blit: ('a, 'b, 'c) t -> ('a, 'b, 'c) t -> unit = "caml_ba_blit" @@ -167,19 +170,21 @@ module Array3 = struct Genarray.create kind layout [|dim1; dim2; dim3|] external get: ('a, 'b, 'c) t -> int -> int -> int -> 'a = "%caml_ba_ref_3" external set: ('a, 'b, 'c) t -> int -> int -> int -> 'a -> unit - = "%caml_ba_set_3" - external unsafe_get: ('a, 'b, 'c) t -> int -> int -> int -> 'a = "%caml_ba_unsafe_ref_3" - external unsafe_set: ('a, 'b, 'c) t -> int -> int -> int -> 'a -> unit = "%caml_ba_unsafe_set_3" + = "%caml_ba_set_3" + external unsafe_get: ('a, 'b, 'c) t -> int -> int -> int -> 'a + = "%caml_ba_unsafe_ref_3" + external unsafe_set: ('a, 'b, 'c) t -> int -> int -> int -> 'a -> unit + = "%caml_ba_unsafe_set_3" external dim1: ('a, 'b, 'c) t -> int = "%caml_ba_dim_1" external dim2: ('a, 'b, 'c) t -> int = "%caml_ba_dim_2" external dim3: ('a, 'b, 'c) t -> int = "%caml_ba_dim_3" external kind: ('a, 'b, 'c) t -> ('a, 'b) kind = "caml_ba_kind" external layout: ('a, 'b, 'c) t -> 'c layout = "caml_ba_layout" external sub_left: ('a, 'b, c_layout) t -> int -> int -> ('a, 'b, c_layout) t - = "caml_ba_sub" + = "caml_ba_sub" external sub_right: - ('a, 'b, fortran_layout) t -> int -> int -> ('a, 'b, fortran_layout) t - = "caml_ba_sub" + ('a, 'b, fortran_layout) t -> int -> int -> ('a, 'b, fortran_layout) t + = "caml_ba_sub" let slice_left_1 a n m = Genarray.slice_left a [|n; m|] let slice_right_1 a n m = Genarray.slice_right a [|n; m|] let slice_left_2 a n = Genarray.slice_left a [|n|] @@ -211,11 +216,11 @@ module Array3 = struct end external genarray_of_array1: ('a, 'b, 'c) Array1.t -> ('a, 'b, 'c) Genarray.t - = "%identity" + = "%identity" external genarray_of_array2: ('a, 'b, 'c) Array2.t -> ('a, 'b, 'c) Genarray.t - = "%identity" + = "%identity" external genarray_of_array3: ('a, 'b, 'c) Array3.t -> ('a, 'b, 'c) Genarray.t - = "%identity" + = "%identity" let array1_of_genarray a = if Genarray.num_dims a = 1 then a else invalid_arg "Bigarray.array1_of_genarray" diff --git a/otherlibs/dynlink/Makefile b/otherlibs/dynlink/Makefile index 3b89450ee9..a95141f4aa 100644 --- a/otherlibs/dynlink/Makefile +++ b/otherlibs/dynlink/Makefile @@ -45,10 +45,12 @@ all: dynlink.cma extract_crc allopt: dynlink.cmxa dynlink.cma: $(OBJS) - $(CAMLC) $(COMPFLAGS) -ccopt "$(NATDYNLINKOPTS)" -a -o dynlink.cma $(OBJS) + $(CAMLC) $(COMPFLAGS) -ccopt "$(NATDYNLINKOPTS)" -a -o dynlink.cma \ + $(OBJS) dynlink.cmxa: $(NATOBJS) - $(CAMLOPT) $(COMPFLAGS) -ccopt "$(NATDYNLINKOPTS)" -a -o dynlink.cmxa $(NATOBJS) + $(CAMLOPT) $(COMPFLAGS) -ccopt "$(NATDYNLINKOPTS)" -a -o dynlink.cmxa \ + $(NATOBJS) dynlinkaux.cmo: $(COMPILEROBJS) $(CAMLC) $(COMPFLAGS) -pack -o dynlinkaux.cmo $(COMPILEROBJS) diff --git a/otherlibs/dynlink/dynlink.ml b/otherlibs/dynlink/dynlink.ml index 89e21aa8ca..fee98f1c1b 100644 --- a/otherlibs/dynlink/dynlink.ml +++ b/otherlibs/dynlink/dynlink.ml @@ -48,11 +48,14 @@ let () = | Unsafe_file -> "Unsafe_file" | Linking_error (s, Undefined_global s') -> - Printf.sprintf "Linking_error (%S, Dynlink.Undefined_global %S)" s s' + Printf.sprintf "Linking_error (%S, Dynlink.Undefined_global %S)" + s s' | Linking_error (s, Unavailable_primitive s') -> - Printf.sprintf "Linking_error (%S, Dynlink.Unavailable_primitive %S)" s s' + Printf.sprintf "Linking_error (%S, Dynlink.Unavailable_primitive \ + %S)" s s' | Linking_error (s, Uninitialized_global s') -> - Printf.sprintf "Linking_error (%S, Dynlink.Uninitialized_global %S)" s s' + Printf.sprintf "Linking_error (%S, Dynlink.Uninitialized_global \ + %S)" s s' | Corrupted_interface s -> Printf.sprintf "Corrupted_interface %S" s | File_not_found s -> @@ -232,7 +235,8 @@ let load_compunit ic file_name file_digest compunit = let loadfile file_name = init(); - if not (Sys.file_exists file_name) then raise(Error (File_not_found file_name)); + if not (Sys.file_exists file_name) + then raise (Error (File_not_found file_name)); let ic = open_in_bin file_name in let file_digest = Digest.channel ic (-1) in seek_in ic 0; diff --git a/otherlibs/graph/Makefile b/otherlibs/graph/Makefile index 7ef50c8e7a..9586f1c4bb 100644 --- a/otherlibs/graph/Makefile +++ b/otherlibs/graph/Makefile @@ -26,7 +26,7 @@ EXTRACFLAGS=$(X11_INCLUDES) include ../Makefile depend: - gcc -MM $(CFLAGS) *.c | sed -e 's, /usr[^ ]*\.h,,g' > .depend + gcc -MM $(CFLAGS) *.c | sed -e 's, /[^ ]*\.h,,g' > .depend ../../boot/ocamlrun ../../tools/ocamldep *.mli *.ml >> .depend include .depend diff --git a/otherlibs/graph/color.c b/otherlibs/graph/color.c index 02641ae8ed..5b94060523 100644 --- a/otherlibs/graph/color.c +++ b/otherlibs/graph/color.c @@ -97,7 +97,8 @@ void caml_gr_init_direct_rgb_to_pixel(void) fprintf(stderr, "green %d %d\n", caml_gr_green_l, caml_gr_green_r); #endif for(i=0; i<256; i++){ - caml_gr_green_vals[i] = (((i << 8) + i) >> caml_gr_green_r) << caml_gr_green_l; + caml_gr_green_vals[i] = + (((i << 8) + i) >> caml_gr_green_r) << caml_gr_green_l; } caml_gr_get_shifts(caml_gr_blue_mask, &caml_gr_blue_l, &caml_gr_blue_r); @@ -105,7 +106,8 @@ void caml_gr_init_direct_rgb_to_pixel(void) fprintf(stderr, "blue %d %d\n", caml_gr_blue_l, caml_gr_blue_r); #endif for(i=0; i<256; i++){ - caml_gr_blue_vals[i] = (((i << 8) + i) >> caml_gr_blue_r) << caml_gr_blue_l; + caml_gr_blue_vals[i] = + (((i << 8) + i) >> caml_gr_blue_r) << caml_gr_blue_l; } if( caml_gr_red_l < 0 || caml_gr_red_r < 0 || @@ -189,9 +191,12 @@ int caml_gr_rgb_pixel(long unsigned int pixel) int i; if (caml_gr_direct_rgb) { - r = (((pixel & caml_gr_red_mask) >> caml_gr_red_l) << 8) >> (16 - caml_gr_red_r); - g = (((pixel & caml_gr_green_mask) >> caml_gr_green_l) << 8) >> (16 - caml_gr_green_r); - b = (((pixel & caml_gr_blue_mask) >> caml_gr_blue_l) << 8) >> (16 - caml_gr_blue_r); + r = (((pixel & caml_gr_red_mask) >> caml_gr_red_l) << 8) + >> (16 - caml_gr_red_r); + g = (((pixel & caml_gr_green_mask) >> caml_gr_green_l) << 8) + >> (16 - caml_gr_green_r); + b = (((pixel & caml_gr_blue_mask) >> caml_gr_blue_l) << 8) + >> (16 - caml_gr_blue_r); return (r << 16) + (g << 8) + b; } diff --git a/otherlibs/graph/draw.c b/otherlibs/graph/draw.c index 3670111503..dc65787542 100644 --- a/otherlibs/graph/draw.c +++ b/otherlibs/graph/draw.c @@ -20,9 +20,11 @@ value caml_gr_plot(value vx, value vy) int y = Int_val(vy); caml_gr_check_open(); if(caml_gr_remember_modeflag) - XDrawPoint(caml_gr_display, caml_gr_bstore.win, caml_gr_bstore.gc, x, Bcvt(y)); + XDrawPoint(caml_gr_display, caml_gr_bstore.win, caml_gr_bstore.gc, x, + Bcvt(y)); if(caml_gr_display_modeflag) { - XDrawPoint(caml_gr_display, caml_gr_window.win, caml_gr_window.gc, x, Wcvt(y)); + XDrawPoint(caml_gr_display, caml_gr_window.win, caml_gr_window.gc, x, + Wcvt(y)); XFlush(caml_gr_display); } return Val_unit; @@ -82,7 +84,8 @@ value caml_gr_draw_rect(value vx, value vy, value vw, value vh) return Val_unit; } -value caml_gr_draw_arc_nat(value vx, value vy, value vrx, value vry, value va1, value va2) +value caml_gr_draw_arc_nat(value vx, value vy, value vrx, value vry, value va1, + value va2) { int x = Int_val(vx); int y = Int_val(vy); @@ -105,7 +108,8 @@ value caml_gr_draw_arc_nat(value vx, value vy, value vrx, value vry, value va1, value caml_gr_draw_arc(value *argv, int argc) { - return caml_gr_draw_arc_nat(argv[0], argv[1], argv[2], argv[3], argv[4], argv[5]); + return caml_gr_draw_arc_nat(argv[0], argv[1], argv[2], argv[3], argv[4], + argv[5]); } value caml_gr_set_line_width(value vwidth) diff --git a/otherlibs/graph/dump_img.c b/otherlibs/graph/dump_img.c index bf562a78ab..4ba5c066ca 100644 --- a/otherlibs/graph/dump_img.c +++ b/otherlibs/graph/dump_img.c @@ -33,15 +33,18 @@ value caml_gr_dump_image(value image) } idata = - XGetImage(caml_gr_display, Data_im(image), 0, 0, width, height, (-1), ZPixmap); + XGetImage(caml_gr_display, Data_im(image), 0, 0, width, height, (-1), + ZPixmap); for (i = 0; i < height; i++) for (j = 0; j < width; j++) - Field(Field(m, i), j) = Val_int(caml_gr_rgb_pixel(XGetPixel(idata, j, i))); + Field(Field(m, i), j) = + Val_int(caml_gr_rgb_pixel(XGetPixel(idata, j, i))); XDestroyImage(idata); if (Mask_im(image) != None) { imask = - XGetImage(caml_gr_display, Mask_im(image), 0, 0, width, height, 1, ZPixmap); + XGetImage(caml_gr_display, Mask_im(image), 0, 0, width, height, 1, + ZPixmap); for (i = 0; i < height; i++) for (j = 0; j < width; j++) if (XGetPixel(imask, j, i) == 0) diff --git a/otherlibs/graph/events.c b/otherlibs/graph/events.c index d2e94ebd6e..94bd8bc478 100644 --- a/otherlibs/graph/events.c +++ b/otherlibs/graph/events.c @@ -60,8 +60,10 @@ void caml_gr_handle_event(XEvent * event) switch (event->type) { case Expose: - XCopyArea(caml_gr_display, caml_gr_bstore.win, caml_gr_window.win, caml_gr_window.gc, - event->xexpose.x, event->xexpose.y + caml_gr_bstore.h - caml_gr_window.h, + XCopyArea(caml_gr_display, caml_gr_bstore.win, caml_gr_window.win, + caml_gr_window.gc, + event->xexpose.x, + event->xexpose.y + caml_gr_bstore.h - caml_gr_window.h, event->xexpose.width, event->xexpose.height, event->xexpose.x, event->xexpose.y); XFlush(caml_gr_display); @@ -70,7 +72,8 @@ void caml_gr_handle_event(XEvent * event) case ConfigureNotify: caml_gr_window.w = event->xconfigure.width; caml_gr_window.h = event->xconfigure.height; - if (caml_gr_window.w > caml_gr_bstore.w || caml_gr_window.h > caml_gr_bstore.h) { + if (caml_gr_window.w > caml_gr_bstore.w + || caml_gr_window.h > caml_gr_bstore.h) { /* Allocate a new backing store large enough to accomodate both the old backing store and the current window. */ @@ -78,7 +81,8 @@ void caml_gr_handle_event(XEvent * event) newbstore.w = max(caml_gr_window.w, caml_gr_bstore.w); newbstore.h = max(caml_gr_window.h, caml_gr_bstore.h); newbstore.win = - XCreatePixmap(caml_gr_display, caml_gr_window.win, newbstore.w, newbstore.h, + XCreatePixmap(caml_gr_display, caml_gr_window.win, newbstore.w, + newbstore.h, XDefaultDepth(caml_gr_display, caml_gr_screen)); newbstore.gc = XCreateGC(caml_gr_display, newbstore.win, 0, NULL); XSetBackground(caml_gr_display, newbstore.gc, caml_gr_white); @@ -90,8 +94,10 @@ void caml_gr_handle_event(XEvent * event) XSetFont(caml_gr_display, newbstore.gc, caml_gr_font->fid); /* Copy the old backing store into the new one */ - XCopyArea(caml_gr_display, caml_gr_bstore.win, newbstore.win, newbstore.gc, - 0, 0, caml_gr_bstore.w, caml_gr_bstore.h, 0, newbstore.h - caml_gr_bstore.h); + XCopyArea(caml_gr_display, caml_gr_bstore.win, newbstore.win, + newbstore.gc, + 0, 0, caml_gr_bstore.w, caml_gr_bstore.h, 0, + newbstore.h - caml_gr_bstore.h); /* Free the old backing store */ XFreeGC(caml_gr_display, caml_gr_bstore.gc); @@ -153,6 +159,7 @@ static value caml_gr_wait_event_poll(void) unsigned int modifiers; unsigned int i; + caml_process_pending_signals (); if (XQueryPointer(caml_gr_display, caml_gr_window.win, &rootwin, &childwin, &root_x, &root_y, &win_x, &win_y, @@ -175,7 +182,8 @@ static value caml_gr_wait_event_poll(void) break; } } - return caml_gr_wait_allocate_result(mouse_x, mouse_y, button, keypressed, key); + return + caml_gr_wait_allocate_result(mouse_x, mouse_y, button, keypressed, key); } static value caml_gr_wait_event_in_queue(long mask) diff --git a/otherlibs/graph/fill.c b/otherlibs/graph/fill.c index 4eb9f34745..1e2965f179 100644 --- a/otherlibs/graph/fill.c +++ b/otherlibs/graph/fill.c @@ -59,7 +59,8 @@ value caml_gr_fill_poly(value array) return Val_unit; } -value caml_gr_fill_arc_nat(value vx, value vy, value vrx, value vry, value va1, value va2) +value caml_gr_fill_arc_nat(value vx, value vy, value vrx, value vry, value va1, + value va2) { int x = Int_val(vx); int y = Int_val(vy); @@ -82,5 +83,6 @@ value caml_gr_fill_arc_nat(value vx, value vy, value vrx, value vry, value va1, value caml_gr_fill_arc(value *argv, int argc) { - return caml_gr_fill_arc_nat(argv[0], argv[1], argv[2], argv[3], argv[4], argv[5]); + return caml_gr_fill_arc_nat(argv[0], argv[1], argv[2], argv[3], argv[4], + argv[5]); } diff --git a/otherlibs/graph/graphics.ml b/otherlibs/graph/graphics.ml index c45c5bfcab..441c6760cd 100644 --- a/otherlibs/graph/graphics.ml +++ b/otherlibs/graph/graphics.ml @@ -212,6 +212,18 @@ let read_key () = let key_pressed () = let e = wait_next_event [Poll] in e.keypressed +let loop_at_exit events handler = + let events = List.filter (fun e -> e <> Poll) events in + at_exit (fun _ -> + try + while true do + let e = wait_next_event events in + handler e + done + with Exit -> close_graph () + | e -> close_graph (); raise e + ) + (*** Sound *) external sound : int -> int -> unit = "caml_gr_sound" diff --git a/otherlibs/graph/graphics.mli b/otherlibs/graph/graphics.mli index e1dce5263c..81cd4eeb05 100644 --- a/otherlibs/graph/graphics.mli +++ b/otherlibs/graph/graphics.mli @@ -303,6 +303,14 @@ external wait_next_event : event list -> status = "caml_gr_wait_event" are queued, and dequeued one by one when the [Key_pressed] event is specified. *) +val loop_at_exit : event list -> (status -> unit) -> unit +(** Loop before exiting the program, the list given as argument is the + list of handlers and the events on which these handlers are called. + To exit cleanly the loop, the handler should raise Exit. Any other + exception will be propagated outside of the loop. + @since 4.01 +*) + (** {6 Mouse and keyboard polling} *) val mouse_pos : unit -> int * int diff --git a/otherlibs/graph/graphicsX11.ml b/otherlibs/graph/graphicsX11.ml index 066952ce67..33ef1bc97c 100644 --- a/otherlibs/graph/graphicsX11.ml +++ b/otherlibs/graph/graphicsX11.ml @@ -11,7 +11,8 @@ (* *) (***********************************************************************) -(* Module [GraphicsX11]: additional graphics primitives for the X Windows system *) +(* Module [GraphicsX11]: additional graphics primitives for + the X Windows system *) type window_id = string @@ -35,5 +36,5 @@ let close_subwindow wid = close_subwindow wid; Hashtbl.remove subwindows wid end else - raise (Graphics.Graphic_failure ("close_subwindow: no such subwindow: " ^ wid)) + raise (Graphics.Graphic_failure("close_subwindow: no such subwindow: "^wid)) ;; diff --git a/otherlibs/graph/image.c b/otherlibs/graph/image.c index 40bce33570..31693bbd3e 100644 --- a/otherlibs/graph/image.c +++ b/otherlibs/graph/image.c @@ -83,12 +83,14 @@ value caml_gr_draw_image(value im, value vx, value vy) } } if(caml_gr_remember_modeflag) - XCopyArea(caml_gr_display, Data_im(im), caml_gr_bstore.win, caml_gr_bstore.gc, + XCopyArea(caml_gr_display, Data_im(im), caml_gr_bstore.win, + caml_gr_bstore.gc, 0, 0, Width_im(im), Height_im(im), x, by); if(caml_gr_display_modeflag) - XCopyArea(caml_gr_display, Data_im(im), caml_gr_window.win, caml_gr_window.gc, + XCopyArea(caml_gr_display, Data_im(im), caml_gr_window.win, + caml_gr_window.gc, 0, 0, Width_im(im), Height_im(im), x, wy); diff --git a/otherlibs/graph/libgraph.h b/otherlibs/graph/libgraph.h index cf63964106..16d8b3b1df 100644 --- a/otherlibs/graph/libgraph.h +++ b/otherlibs/graph/libgraph.h @@ -32,8 +32,8 @@ extern int caml_gr_background; /* Background color for X (used for CAML color -1) */ extern Bool caml_gr_display_modeflag; /* Display-mode flag */ extern Bool caml_gr_remember_modeflag; /* Remember-mode flag */ -extern int caml_gr_x, caml_gr_y; /* Coordinates of the current point */ -extern int caml_gr_color; /* Current *CAML* drawing color (can be -1) */ +extern int caml_gr_x, caml_gr_y; /* Coordinates of the current point */ +extern int caml_gr_color; /* Current *CAML* drawing color (can be -1) */ extern XFontStruct * caml_gr_font; /* Current font */ extern long caml_gr_selected_events; /* Events we are interested in */ extern Bool caml_gr_ignore_sigio; /* Whether to consume events on sigio */ diff --git a/otherlibs/graph/make_img.c b/otherlibs/graph/make_img.c index e65c7a00da..932d4605d9 100644 --- a/otherlibs/graph/make_img.c +++ b/otherlibs/graph/make_img.c @@ -36,7 +36,8 @@ value caml_gr_make_image(value m) /* Build an XImage for the data part of the image */ idata = - XCreateImage(caml_gr_display, DefaultVisual(caml_gr_display, caml_gr_screen), + XCreateImage(caml_gr_display, + DefaultVisual(caml_gr_display, caml_gr_screen), XDefaultDepth(caml_gr_display, caml_gr_screen), ZPixmap, 0, NULL, width, height, BitmapPad(caml_gr_display), 0); @@ -58,7 +59,8 @@ value caml_gr_make_image(value m) build an XImage for the mask part of the image */ if (has_transp) { imask = - XCreateImage(caml_gr_display, DefaultVisual(caml_gr_display, caml_gr_screen), + XCreateImage(caml_gr_display, + DefaultVisual(caml_gr_display, caml_gr_screen), 1, ZPixmap, 0, NULL, width, height, BitmapPad(caml_gr_display), 0); bmask = (char *) caml_stat_alloc(height * imask->bytes_per_line); @@ -82,9 +84,11 @@ value caml_gr_make_image(value m) XDestroyImage(idata); XFreeGC(caml_gr_display, gc); if (has_transp) { - Mask_im(im) = XCreatePixmap(caml_gr_display, caml_gr_window.win, width, height, 1); + Mask_im(im) = XCreatePixmap(caml_gr_display, caml_gr_window.win, width, + height, 1); gc = XCreateGC(caml_gr_display, Mask_im(im), 0, NULL); - XPutImage(caml_gr_display, Mask_im(im), gc, imask, 0, 0, 0, 0, width, height); + XPutImage(caml_gr_display, Mask_im(im), gc, imask, 0, 0, 0, 0, width, + height); XDestroyImage(imask); XFreeGC(caml_gr_display, gc); } diff --git a/otherlibs/graph/open.c b/otherlibs/graph/open.c index 9cb4ba5c2e..e3529d42df 100644 --- a/otherlibs/graph/open.c +++ b/otherlibs/graph/open.c @@ -93,7 +93,8 @@ value caml_gr_open_graph(value arg) hints.flags = PPosition | PSize; hints.win_gravity = 0; - ret = XWMGeometry(caml_gr_display, caml_gr_screen, geometry_spec, "", BORDER_WIDTH, + ret = XWMGeometry(caml_gr_display, caml_gr_screen, geometry_spec, "", + BORDER_WIDTH, &hints, &x, &y, &w, &h, &hints.win_gravity); if (ret & (XValue | YValue)) { hints.x = x; hints.y = y; hints.flags |= USPosition; @@ -138,7 +139,8 @@ value caml_gr_open_graph(value arg) caml_gr_bstore.w = caml_gr_window.w; caml_gr_bstore.h = caml_gr_window.h; caml_gr_bstore.win = - XCreatePixmap(caml_gr_display, caml_gr_window.win, caml_gr_bstore.w, caml_gr_bstore.h, + XCreatePixmap(caml_gr_display, caml_gr_window.win, caml_gr_bstore.w, + caml_gr_bstore.h, XDefaultDepth(caml_gr_display, caml_gr_screen)); caml_gr_bstore.gc = XCreateGC(caml_gr_display, caml_gr_bstore.win, 0, NULL); XSetBackground(caml_gr_display, caml_gr_bstore.gc, caml_gr_background); @@ -211,7 +213,9 @@ value caml_gr_close_graph(void) setitimer(ITIMER_REAL, &it, NULL); #endif caml_gr_initialized = False; - if (caml_gr_font != NULL) { XFreeFont(caml_gr_display, caml_gr_font); caml_gr_font = NULL; } + if (caml_gr_font != NULL) { + XFreeFont(caml_gr_display, caml_gr_font); caml_gr_font = NULL; + } XFreeGC(caml_gr_display, caml_gr_window.gc); XDestroyWindow(caml_gr_display, caml_gr_window.win); XFreeGC(caml_gr_display, caml_gr_bstore.gc); @@ -311,7 +315,8 @@ value caml_gr_size_y(void) value caml_gr_synchronize(void) { caml_gr_check_open(); - XCopyArea(caml_gr_display, caml_gr_bstore.win, caml_gr_window.win, caml_gr_window.gc, + XCopyArea(caml_gr_display, caml_gr_bstore.win, caml_gr_window.win, + caml_gr_window.gc, 0, caml_gr_bstore.h - caml_gr_window.h, caml_gr_window.w, caml_gr_window.h, 0, 0); @@ -367,7 +372,8 @@ void caml_gr_fail(char *fmt, char *arg) if (graphic_failure_exn == NULL) { graphic_failure_exn = caml_named_value("Graphics.Graphic_failure"); if (graphic_failure_exn == NULL) - invalid_argument("Exception Graphics.Graphic_failure not initialized, must link graphics.cma"); + invalid_argument("Exception Graphics.Graphic_failure not initialized," + " must link graphics.cma"); } sprintf(buffer, fmt, arg); raise_with_string(*graphic_failure_exn, buffer); diff --git a/otherlibs/graph/point_col.c b/otherlibs/graph/point_col.c index af061e9073..da1e879986 100644 --- a/otherlibs/graph/point_col.c +++ b/otherlibs/graph/point_col.c @@ -21,7 +21,8 @@ value caml_gr_point_color(value vx, value vy) int rgb; caml_gr_check_open(); - im = XGetImage(caml_gr_display, caml_gr_bstore.win, x, Bcvt(y), 1, 1, (-1), ZPixmap); + im = XGetImage(caml_gr_display, caml_gr_bstore.win, x, Bcvt(y), 1, 1, (-1), + ZPixmap); rgb = caml_gr_rgb_pixel(XGetPixel(im, 0, 0)); XDestroyImage(im); return Val_int(rgb); diff --git a/otherlibs/graph/text.c b/otherlibs/graph/text.c index d92d4ae5ec..8ac422d58d 100644 --- a/otherlibs/graph/text.c +++ b/otherlibs/graph/text.c @@ -43,10 +43,12 @@ static void caml_gr_draw_text(char *txt, int len) if (caml_gr_font == NULL) caml_gr_get_font(DEFAULT_FONT); if (caml_gr_remember_modeflag) XDrawString(caml_gr_display, caml_gr_bstore.win, caml_gr_bstore.gc, - caml_gr_x, Bcvt(caml_gr_y) - caml_gr_font->descent + 1, txt, len); + caml_gr_x, Bcvt(caml_gr_y) - caml_gr_font->descent + 1, txt, + len); if (caml_gr_display_modeflag) { XDrawString(caml_gr_display, caml_gr_window.win, caml_gr_window.gc, - caml_gr_x, Wcvt(caml_gr_y) - caml_gr_font->descent + 1, txt, len); + caml_gr_x, Wcvt(caml_gr_y) - caml_gr_font->descent + 1, txt, + len); XFlush(caml_gr_display); } caml_gr_x += XTextWidth(caml_gr_font, txt, len); diff --git a/otherlibs/num/nat.ml b/otherlibs/num/nat.ml index fb46d4584c..c920806f94 100644 --- a/otherlibs/num/nat.ml +++ b/otherlibs/num/nat.ml @@ -353,8 +353,10 @@ let int_to_string int s pos_ref base times = (* XL: suppression de adjust_string *) let power_base_int base i = - if i = 0 then + if i = 0 || base = 1 then nat_of_int 1 + else if base = 0 then + nat_of_int 0 else if i < 0 then invalid_arg "power_base_int" else begin diff --git a/otherlibs/systhreads/Makefile.nt b/otherlibs/systhreads/Makefile.nt index bcb4df7d4a..6a4f682a4c 100644 --- a/otherlibs/systhreads/Makefile.nt +++ b/otherlibs/systhreads/Makefile.nt @@ -30,7 +30,8 @@ all: lib$(LIBNAME).$(A) $(LIBNAME).cma $(CMIFILES) allopt: lib$(LIBNAME).$(A) $(LIBNAME).cmxa $(LIBNAME).cmxs $(CMIFILES) $(LIBNAME).cma: $(CAMLOBJS) - $(MKLIB) -o $(LIBNAME) -ocamlc "../../boot/ocamlrun ../../ocamlc" -linkall $(CAMLOBJS) $(LINKOPTS) + $(MKLIB) -o $(LIBNAME) -ocamlc "../../boot/ocamlrun ../../ocamlc" \ + -linkall $(CAMLOBJS) $(LINKOPTS) lib$(LIBNAME).$(A): $(COBJS) $(MKLIB) -o $(LIBNAME) $(COBJS) $(LDOPTS) @@ -42,7 +43,9 @@ st_stubs_b.$(O): st_stubs.c st_win32.h $(LIBNAME).cmxa: $(CAMLOBJS:.cmo=.cmx) - $(MKLIB) -o $(LIBNAME)nat -ocamlopt "../../boot/ocamlrun ../../ocamlopt" -linkall $(CAMLOBJS:.cmo=.cmx) $(LINKOPTS) + $(MKLIB) -o $(LIBNAME)nat \ + -ocamlopt "../../boot/ocamlrun ../../ocamlopt" -linkall \ + $(CAMLOBJS:.cmo=.cmx) $(LINKOPTS) mv $(LIBNAME)nat.cmxa $(LIBNAME).cmxa mv $(LIBNAME)nat.$(A) $(LIBNAME).$(A) @@ -53,7 +56,8 @@ lib$(LIBNAME)nat.$(A): $(COBJS_NAT) $(MKLIB) -o $(LIBNAME)nat $(COBJS_NAT) $(LDOPTS) st_stubs_n.$(O): st_stubs.c st_win32.h - $(NATIVECC) -DNATIVE_CODE -I../../asmrun -I../../byterun $(NATIVECCCOMPOPTS) -c st_stubs.c + $(NATIVECC) -DNATIVE_CODE -I../../asmrun -I../../byterun \ + $(NATIVECCCOMPOPTS) -c st_stubs.c mv st_stubs.$(O) st_stubs_n.$(O) $(CAMLOBJS:.cmo=.cmx): ../../ocamlopt diff --git a/otherlibs/systhreads/st_stubs.c b/otherlibs/systhreads/st_stubs.c index 02d4c54fc4..dd99c7369a 100644 --- a/otherlibs/systhreads/st_stubs.c +++ b/otherlibs/systhreads/st_stubs.c @@ -823,7 +823,7 @@ CAMLprim value caml_condition_signal(value wrapper) /* ML */ CAMLprim value caml_condition_broadcast(value wrapper) /* ML */ { st_check_error(st_condvar_broadcast(Condition_val(wrapper)), - "Condition.signal"); + "Condition.broadcast"); return Val_unit; } diff --git a/otherlibs/systhreads/st_win32.h b/otherlibs/systhreads/st_win32.h index 8d98f525a3..cd04b319ce 100644 --- a/otherlibs/systhreads/st_win32.h +++ b/otherlibs/systhreads/st_win32.h @@ -27,7 +27,8 @@ #else #include <stdio.h> #define TRACE(x) printf("%d: %s\n", GetCurrentThreadId(), x); fflush(stdout) -#define TRACE1(x,y) printf("%d: %s %p\n", GetCurrentThreadId(), x, (void *)y); fflush(stdout) +#define TRACE1(x,y) printf("%d: %s %p\n", GetCurrentThreadId(), x, (void *)y); \ + fflush(stdout) #endif typedef DWORD st_retcode; diff --git a/otherlibs/systhreads/thread.ml b/otherlibs/systhreads/thread.ml index 58ef115f8f..c7988b5641 100644 --- a/otherlibs/systhreads/thread.ml +++ b/otherlibs/systhreads/thread.ml @@ -83,5 +83,6 @@ let select = Unix.select let wait_pid p = Unix.waitpid [] p -external sigmask : Unix.sigprocmask_command -> int list -> int list = "caml_thread_sigmask" +external sigmask : Unix.sigprocmask_command -> int list -> int list + = "caml_thread_sigmask" external wait_signal : int list -> int = "caml_wait_signal" diff --git a/otherlibs/threads/Makefile b/otherlibs/threads/Makefile index 0fd1d64682..7a93c1632a 100644 --- a/otherlibs/threads/Makefile +++ b/otherlibs/threads/Makefile @@ -111,9 +111,11 @@ install: mkdir -p $(LIBDIR)/vmthreads cp libvmthreads.a $(LIBDIR)/vmthreads/libvmthreads.a cd $(LIBDIR)/vmthreads; $(RANLIB) libvmthreads.a - cp thread.cmi mutex.cmi condition.cmi event.cmi threadUnix.cmi threads.cma stdlib.cma unix.cma $(LIBDIR)/vmthreads + cp thread.cmi mutex.cmi condition.cmi event.cmi threadUnix.cmi \ + threads.cma stdlib.cma unix.cma $(LIBDIR)/vmthreads cp join_prim.cmi join_test.cmi $(LIBDIR)/vmthreads - cp thread.mli mutex.mli condition.mli event.mli threadUnix.mli $(LIBDIR)/vmthreads + cp thread.mli mutex.mli condition.mli event.mli threadUnix.mli \ + $(LIBDIR)/vmthreads installopt: diff --git a/otherlibs/threads/pervasives.ml b/otherlibs/threads/pervasives.ml index 960eb25eb1..fdba7953dd 100644 --- a/otherlibs/threads/pervasives.ml +++ b/otherlibs/threads/pervasives.ml @@ -97,7 +97,8 @@ external acos : float -> float = "caml_acos_float" "acos" "float" external asin : float -> float = "caml_asin_float" "asin" "float" external atan : float -> float = "caml_atan_float" "atan" "float" external atan2 : float -> float -> float = "caml_atan2_float" "atan2" "float" -external hypot : float -> float -> float = "caml_hypot_float" "caml_hypot" "float" +external hypot : float -> float -> float + = "caml_hypot_float" "caml_hypot" "float" external cos : float -> float = "caml_cos_float" "cos" "float" external cosh : float -> float = "caml_cosh_float" "cosh" "float" external log : float -> float = "caml_log_float" "log" "float" @@ -111,7 +112,8 @@ external tanh : float -> float = "caml_tanh_float" "tanh" "float" external ceil : float -> float = "caml_ceil_float" "ceil" "float" external floor : float -> float = "caml_floor_float" "floor" "float" external abs_float : float -> float = "%absfloat" -external copysign : float -> float -> float = "caml_copysign_float" "caml_copysign" "float" +external copysign : float -> float -> float + = "caml_copysign_float" "caml_copysign" "float" external mod_float : float -> float -> float = "caml_fmod_float" "fmod" "float" external frexp : float -> float * int = "caml_frexp_float" external ldexp : float -> int -> float = "caml_ldexp_float" diff --git a/otherlibs/threads/thread.ml b/otherlibs/threads/thread.ml index 646ad3c4a6..6ef9997d8c 100644 --- a/otherlibs/threads/thread.ml +++ b/otherlibs/threads/thread.ml @@ -42,7 +42,8 @@ let _ = [Resumed_wakeup; Resumed_delay; Resumed_join; must take exactly one argument. *) external thread_initialize : unit -> unit = "thread_initialize" -external thread_initialize_preemption : unit -> unit = "thread_initialize_preemption" +external thread_initialize_preemption : unit -> unit + = "thread_initialize_preemption" external thread_new : (unit -> unit) -> t = "thread_new" external thread_yield : unit -> unit = "thread_yield" external thread_request_reschedule : unit -> unit = "thread_request_reschedule" diff --git a/otherlibs/threads/unix.ml b/otherlibs/threads/unix.ml index 53aaecfb2b..80ea7aed64 100644 --- a/otherlibs/threads/unix.ml +++ b/otherlibs/threads/unix.ml @@ -196,6 +196,7 @@ type open_flag = | O_SYNC | O_RSYNC | O_SHARE_DELETE + | O_CLOEXEC type file_perm = int diff --git a/otherlibs/unix/open.c b/otherlibs/unix/open.c index 097a0455ba..ecee013898 100644 --- a/otherlibs/unix/open.c +++ b/otherlibs/unix/open.c @@ -17,6 +17,9 @@ #include <signals.h> #include "unixsupport.h" #include <string.h> +#ifdef HAS_UNISTD +#include <unistd.h> +#endif #include <fcntl.h> #ifndef O_NONBLOCK @@ -31,16 +34,31 @@ #ifndef O_RSYNC #define O_RSYNC 0 #endif +#ifndef O_CLOEXEC +#define NEED_CLOEXEC_EMULATION +#define O_CLOEXEC 0 +#endif -static int open_flag_table[] = { +static int open_flag_table[14] = { O_RDONLY, O_WRONLY, O_RDWR, O_NONBLOCK, O_APPEND, O_CREAT, O_TRUNC, O_EXCL, - O_NOCTTY, O_DSYNC, O_SYNC, O_RSYNC, 0 + O_NOCTTY, O_DSYNC, O_SYNC, O_RSYNC, + 0, /* O_SHARE_DELETE, Windows-only */ + O_CLOEXEC +}; + +#ifdef NEED_CLOEXEC_EMULATION +static int open_cloexec_table[14] = { + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, + 0, + 1 }; +#endif CAMLprim value unix_open(value path, value flags, value perm) { CAMLparam3(path, flags, perm); - int ret, cv_flags; + int fd, cv_flags; char * p; cv_flags = convert_flag_list(flags, open_flag_table); @@ -48,9 +66,17 @@ CAMLprim value unix_open(value path, value flags, value perm) strcpy(p, String_val(path)); /* open on a named FIFO can block (PR#1533) */ enter_blocking_section(); - ret = open(p, cv_flags, Int_val(perm)); + fd = open(p, cv_flags, Int_val(perm)); leave_blocking_section(); stat_free(p); - if (ret == -1) uerror("open", path); - CAMLreturn (Val_int(ret)); + if (fd == -1) uerror("open", path); +#if defined(NEED_CLOEXEC_EMULATION) && defined(FD_CLOEXEC) + if (convert_flag_list(flags, open_cloexec_table) != 0) { + int flags = fcntl(fd, F_GETFD, 0); + if (flags == -1 || + fcntl(fd, F_SETFD, flags | FD_CLOEXEC) == -1) + uerror("open", path); + } +#endif + CAMLreturn (Val_int(fd)); } diff --git a/otherlibs/unix/unix.ml b/otherlibs/unix/unix.ml index 8a69ca7b44..8bd935f4cb 100644 --- a/otherlibs/unix/unix.ml +++ b/otherlibs/unix/unix.ml @@ -202,7 +202,8 @@ external execvp : string -> string array -> 'a = "unix_execvp" external execvpe : string -> string array -> string array -> 'a = "unix_execvpe" external fork : unit -> int = "unix_fork" external wait : unit -> int * process_status = "unix_wait" -external waitpid : wait_flag list -> int -> int * process_status = "unix_waitpid" +external waitpid : wait_flag list -> int -> int * process_status + = "unix_waitpid" external getpid : unit -> int = "unix_getpid" external getppid : unit -> int = "unix_getppid" external nice : int -> int = "unix_nice" @@ -227,6 +228,7 @@ type open_flag = | O_SYNC | O_RSYNC | O_SHARE_DELETE + | O_CLOEXEC type file_perm = int @@ -237,7 +239,8 @@ external openfile : string -> open_flag list -> file_perm -> file_descr external close : file_descr -> unit = "unix_close" external unsafe_read : file_descr -> string -> int -> int -> int = "unix_read" external unsafe_write : file_descr -> string -> int -> int -> int = "unix_write" -external unsafe_single_write : file_descr -> string -> int -> int -> int = "unix_single_write" +external unsafe_single_write : file_descr -> string -> int -> int -> int + = "unix_single_write" let read fd buf ofs len = if ofs < 0 || len < 0 || ofs > String.length buf - len @@ -306,7 +309,8 @@ external link : string -> string -> unit = "unix_link" module LargeFile = struct - external lseek : file_descr -> int64 -> seek_command -> int64 = "unix_lseek_64" + external lseek : file_descr -> int64 -> seek_command -> int64 + = "unix_lseek_64" external truncate : string -> int64 -> unit = "unix_truncate_64" external ftruncate : file_descr -> int64 -> unit = "unix_ftruncate_64" type stats = diff --git a/otherlibs/unix/unix.mli b/otherlibs/unix/unix.mli index a9b5510419..a483e42520 100644 --- a/otherlibs/unix/unix.mli +++ b/otherlibs/unix/unix.mli @@ -242,6 +242,9 @@ type open_flag = O_SYNC/O_DSYNC) *) | O_SHARE_DELETE (** Windows only: allow the file to be deleted while still open *) + | O_CLOEXEC (** Set the close-on-exec flag on the + descriptor returned by {!openfile} *) + (** The flags to {!Unix.openfile}. *) @@ -250,9 +253,9 @@ type file_perm = int read for group, none for others *) val openfile : string -> open_flag list -> file_perm -> file_descr -(** Open the named file with the given flags. Third argument is - the permissions to give to the file if it is created. Return - a file descriptor on the named file. *) +(** Open the named file with the given flags. Third argument is the + permissions to give to the file if it is created (see + {!umask}). Return a file descriptor on the named file. *) val close : file_descr -> unit (** Close a file descriptor. *) @@ -480,7 +483,7 @@ val clear_close_on_exec : file_descr -> unit val mkdir : string -> file_perm -> unit -(** Create a directory with the given permissions. *) +(** Create a directory with the given permissions (see {!umask}). *) val rmdir : string -> unit (** Remove an empty directory. *) @@ -521,7 +524,7 @@ val pipe : unit -> file_descr * file_descr opened for writing, that's the entrance to the pipe. *) val mkfifo : string -> file_perm -> unit -(** Create a named pipe with the given permissions. *) +(** Create a named pipe with the given permissions (see {!umask}). *) (** {6 High-level process and redirection management} *) diff --git a/otherlibs/unix/unixLabels.mli b/otherlibs/unix/unixLabels.mli index 91636c6a8b..4dc411b0b5 100644 --- a/otherlibs/unix/unixLabels.mli +++ b/otherlibs/unix/unixLabels.mli @@ -183,7 +183,8 @@ val wait : unit -> int * process_status and termination status. *) val waitpid : mode:wait_flag list -> int -> int * process_status -(** Same as {!UnixLabels.wait}, but waits for the child process whose pid is given. +(** Same as {!UnixLabels.wait}, but waits for the child process whose pid + is given. A pid of [-1] means wait for any child. A pid of [0] means wait for any child in the same process group as the current process. @@ -239,6 +240,8 @@ type open_flag = Unix.open_flag = | O_SYNC (** Writes complete as `Synchronised I/O file integrity completion' *) | O_RSYNC (** Reads complete as writes (depending on O_SYNC/O_DSYNC) *) | O_SHARE_DELETE (** Windows only: allow the file to be deleted while still open *) + | O_CLOEXEC (** Set the close-on-exec flag on the + descriptor returned by {!openfile} *) (** The flags to {!UnixLabels.openfile}. *) diff --git a/otherlibs/unix/unixsupport.c b/otherlibs/unix/unixsupport.c index 15365f802e..f1df3fc72c 100644 --- a/otherlibs/unix/unixsupport.c +++ b/otherlibs/unix/unixsupport.c @@ -270,6 +270,15 @@ value unix_error_of_code (int errcode) return err; } +extern int code_of_unix_error (value error) +{ + if (Is_block(error)) { + return Int_val(Field(error, 0)); + } else { + return error_table[Int_val(error)]; + } +} + void unix_error(int errcode, char *cmdname, value cmdarg) { value res; @@ -282,7 +291,8 @@ void unix_error(int errcode, char *cmdname, value cmdarg) if (unix_error_exn == NULL) { unix_error_exn = caml_named_value("Unix.Unix_error"); if (unix_error_exn == NULL) - invalid_argument("Exception Unix.Unix_error not initialized, please link unix.cma"); + invalid_argument("Exception Unix.Unix_error not initialized," + " please link unix.cma"); } res = alloc_small(4, 0); Field(res, 0) = *unix_error_exn; diff --git a/otherlibs/unix/unixsupport.h b/otherlibs/unix/unixsupport.h index 4706355eb0..a8065d973a 100644 --- a/otherlibs/unix/unixsupport.h +++ b/otherlibs/unix/unixsupport.h @@ -18,6 +18,7 @@ #define Nothing ((value) 0) extern value unix_error_of_code (int errcode); +extern int code_of_unix_error (value error); extern void unix_error (int errcode, char * cmdname, value arg) Noreturn; extern void uerror (char * cmdname, value arg) Noreturn; diff --git a/parsing/ast_mapper.ml b/parsing/ast_mapper.ml index a296c72120..41826daa19 100644 --- a/parsing/ast_mapper.ml +++ b/parsing/ast_mapper.ml @@ -71,13 +71,18 @@ module T = struct | Ptyp_var s -> var ~loc s | Ptyp_arrow (lab, t1, t2) -> arrow ~loc lab (sub # typ t1) (sub # typ t2) | Ptyp_tuple tyl -> tuple ~loc (List.map (sub # typ) tyl) - | Ptyp_constr (lid, tl) -> constr ~loc (map_loc sub lid) (List.map (sub # typ) tl) + | Ptyp_constr (lid, tl) -> + constr ~loc (map_loc sub lid) (List.map (sub # typ) tl) | Ptyp_object l -> object_ ~loc (List.map (core_field_type sub) l) - | Ptyp_class (lid, tl, ll) -> class_ ~loc (map_loc sub lid) (List.map (sub # typ) tl) ll + | Ptyp_class (lid, tl, ll) -> + class_ ~loc (map_loc sub lid) (List.map (sub # typ) tl) ll | Ptyp_alias (t, s) -> alias ~loc (sub # typ t) s - | Ptyp_variant (rl, b, ll) -> variant ~loc (List.map (row_field sub) rl) b ll + | Ptyp_variant (rl, b, ll) -> + variant ~loc (List.map (row_field sub) rl) b ll | Ptyp_poly (sl, t) -> poly ~loc sl (sub # typ t) - | Ptyp_package (lid, l) -> package ~loc (map_loc sub lid) (List.map (map_tuple (map_loc sub) (sub # typ)) l) + | Ptyp_package (lid, l) -> + package ~loc (map_loc sub lid) + (List.map (map_tuple (map_loc sub) (sub # typ)) l) let map_type_declaration sub td = {td with @@ -92,8 +97,19 @@ module T = struct let map_type_kind sub = function | Ptype_abstract -> Ptype_abstract - | Ptype_variant l -> Ptype_variant (List.map (fun (s, tl, t, loc) -> (map_loc sub s, List.map (sub # typ) tl, map_opt (sub # typ) t, sub # location loc)) l) - | Ptype_record l -> Ptype_record (List.map (fun (s, flags, t, loc) -> (map_loc sub s, flags, sub # typ t, sub # location loc)) l) + | Ptype_variant l -> + let f (s, tl, t, loc) = + (map_loc sub s, + List.map (sub # typ) tl, + map_opt (sub # typ) t, + sub # location loc) + in + Ptype_variant (List.map f l) + | Ptype_record l -> + let f (s, flags, t, loc) = + (map_loc sub s, flags, sub # typ t, sub # location loc) + in + Ptype_record (List.map f l) end module CT = struct @@ -108,7 +124,8 @@ module CT = struct let map sub {pcty_loc = loc; pcty_desc = desc} = let loc = sub # location loc in match desc with - | Pcty_constr (lid, tys) -> constr ~loc (map_loc sub lid) (List.map (sub # typ) tys) + | Pcty_constr (lid, tys) -> + constr ~loc (map_loc sub lid) (List.map (sub # typ) tys) | Pcty_signature x -> signature ~loc (sub # class_signature x) | Pcty_fun (lab, t, ct) -> fun_ ~loc lab @@ -155,8 +172,12 @@ module MT = struct match desc with | Pmty_ident s -> ident ~loc (map_loc sub s) | Pmty_signature sg -> signature ~loc (sub # signature sg) - | Pmty_functor (s, mt1, mt2) -> functor_ ~loc (map_loc sub s) (sub # module_type mt1) (sub # module_type mt2) - | Pmty_with (mt, l) -> with_ ~loc (sub # module_type mt) (List.map (map_tuple (map_loc sub) (sub # with_constraint)) l) + | Pmty_functor (s, mt1, mt2) -> + functor_ ~loc (map_loc sub s) (sub # module_type mt1) + (sub # module_type mt2) + | Pmty_with (mt, l) -> + with_ ~loc (sub # module_type mt) + (List.map (map_tuple (map_loc sub) (sub # with_constraint)) l) | Pmty_typeof me -> typeof_ ~loc (sub # module_expr me) let map_with_constraint sub = function @@ -181,17 +202,27 @@ module MT = struct let map_signature_item sub {psig_desc = desc; psig_loc = loc} = let loc = sub # location loc in match desc with - | Psig_value (s, vd) -> value ~loc (map_loc sub s) (sub # value_description vd) - | Psig_type l -> type_ ~loc (List.map (map_tuple (map_loc sub) (sub # type_declaration)) l) - | Psig_exception (s, ed) -> exception_ ~loc (map_loc sub s) (sub # exception_declaration ed) - | Psig_module (s, mt) -> module_ ~loc (map_loc sub s) (sub # module_type mt) - | Psig_recmodule l -> rec_module ~loc (List.map (map_tuple (map_loc sub) (sub # module_type)) l) - | Psig_modtype (s, Pmodtype_manifest mt) -> modtype ~loc (map_loc sub s) (Pmodtype_manifest (sub # module_type mt)) - | Psig_modtype (s, Pmodtype_abstract) -> modtype ~loc (map_loc sub s) Pmodtype_abstract + | Psig_value (s, vd) -> + value ~loc (map_loc sub s) (sub # value_description vd) + | Psig_type l -> + type_ ~loc + (List.map (map_tuple (map_loc sub) (sub # type_declaration)) l) + | Psig_exception (s, ed) -> + exception_ ~loc (map_loc sub s) (sub # exception_declaration ed) + | Psig_module (s, mt) -> + module_ ~loc (map_loc sub s) (sub # module_type mt) + | Psig_recmodule l -> + rec_module ~loc + (List.map (map_tuple (map_loc sub) (sub # module_type)) l) + | Psig_modtype (s, Pmodtype_manifest mt) -> + modtype ~loc (map_loc sub s) (Pmodtype_manifest (sub # module_type mt)) + | Psig_modtype (s, Pmodtype_abstract) -> + modtype ~loc (map_loc sub s) Pmodtype_abstract | Psig_open (ovf, s) -> open_ ~loc ovf (map_loc sub s) | Psig_include mt -> include_ ~loc (sub # module_type mt) | Psig_class l -> class_ ~loc (List.map (sub # class_description) l) - | Psig_class_type l -> class_type ~loc (List.map (sub # class_type_declaration) l) + | Psig_class_type l -> + class_type ~loc (List.map (sub # class_type_declaration) l) end diff --git a/parsing/ast_mapper.mli b/parsing/ast_mapper.mli index 10be4a8ebe..0c3e68ee12 100644 --- a/parsing/ast_mapper.mli +++ b/parsing/ast_mapper.mli @@ -26,7 +26,8 @@ class mapper: method class_signature: class_signature -> class_signature method class_structure: class_structure -> class_structure method class_type: class_type -> class_type - method class_type_declaration: class_type_declaration -> class_type_declaration + method class_type_declaration: + class_type_declaration -> class_type_declaration method class_type_field: class_type_field -> class_type_field method exception_declaration: exception_declaration -> exception_declaration method expr: expression -> expression @@ -94,13 +95,20 @@ module T: val var: ?loc:Location.t -> string -> core_type val arrow: ?loc:Location.t -> label -> core_type -> core_type -> core_type val tuple: ?loc:Location.t -> core_type list -> core_type - val constr: ?loc:Location.t -> Longident.t loc -> core_type list -> core_type + val constr: + ?loc:Location.t -> Longident.t loc -> core_type list -> core_type val object_: ?loc:Location.t -> core_field_type list -> core_type - val class_: ?loc:Location.t -> Longident.t loc -> core_type list -> label list -> core_type + val class_: + ?loc:Location.t -> Longident.t loc -> core_type list -> + label list -> core_type val alias: ?loc:Location.t -> core_type -> string -> core_type - val variant: ?loc:Location.t -> row_field list -> bool -> label list option -> core_type + val variant: + ?loc:Location.t -> row_field list -> bool -> label list option -> + core_type val poly: ?loc:Location.t -> string list -> core_type -> core_type - val package: ?loc:Location.t -> Longident.t loc -> (Longident.t loc * core_type) list -> core_type + val package: + ?loc:Location.t -> Longident.t loc -> + (Longident.t loc * core_type) list -> core_type val field_type: ?loc:Location.t -> core_field_desc -> core_field_type val field: ?loc:Location.t -> string -> core_type -> core_field_type val field_var: ?loc:Location.t -> unit -> core_field_type @@ -114,15 +122,22 @@ module T: module CT: sig val mk: ?loc:Location.t -> class_type_desc -> class_type - val constr: ?loc:Location.t -> Longident.t loc -> core_type list -> class_type + val constr: + ?loc:Location.t -> Longident.t loc -> core_type list -> class_type val signature: ?loc:Location.t -> class_signature -> class_type val fun_: ?loc:Location.t -> label -> core_type -> class_type -> class_type val map: mapper -> class_type -> class_type val mk_field: ?loc:Location.t -> class_type_field_desc -> class_type_field val inher: ?loc:Location.t -> class_type -> class_type_field - val val_: ?loc:Location.t -> string -> mutable_flag -> virtual_flag -> core_type -> class_type_field - val virt: ?loc:Location.t -> string -> private_flag -> core_type -> class_type_field - val meth: ?loc:Location.t -> string -> private_flag -> core_type -> class_type_field + val val_: + ?loc:Location.t -> string -> mutable_flag -> virtual_flag -> + core_type -> class_type_field + val virt: + ?loc:Location.t -> string -> private_flag -> core_type -> + class_type_field + val meth: + ?loc:Location.t -> string -> private_flag -> core_type -> + class_type_field val cstr: ?loc:Location.t -> core_type -> core_type -> class_type_field val map_field: mapper -> class_type_field -> class_type_field val map_signature: mapper -> class_signature -> class_signature @@ -133,22 +148,35 @@ module MT: val mk: ?loc:Location.t -> module_type_desc -> module_type val ident: ?loc:Location.t -> Longident.t loc -> module_type val signature: ?loc:Location.t -> signature -> module_type - val functor_: ?loc:Location.t -> string loc -> module_type -> module_type -> module_type - val with_: ?loc:Location.t -> module_type -> (Longident.t loc * with_constraint) list -> module_type + val functor_: + ?loc:Location.t -> string loc -> module_type -> module_type -> + module_type + val with_: + ?loc:Location.t -> module_type -> + (Longident.t loc * with_constraint) list -> module_type val typeof_: ?loc:Location.t -> module_expr -> module_type val map: mapper -> module_type -> module_type val map_with_constraint: mapper -> with_constraint -> with_constraint val mk_item: ?loc:Location.t -> signature_item_desc -> signature_item - val value: ?loc:Location.t -> string loc -> value_description -> signature_item - val type_: ?loc:Location.t -> (string loc * type_declaration) list -> signature_item - val exception_: ?loc:Location.t -> string loc -> exception_declaration -> signature_item + val value: + ?loc:Location.t -> string loc -> value_description -> signature_item + val type_: + ?loc:Location.t -> (string loc * type_declaration) list -> + signature_item + val exception_: + ?loc:Location.t -> string loc -> exception_declaration -> + signature_item val module_: ?loc:Location.t -> string loc -> module_type -> signature_item - val rec_module: ?loc:Location.t -> (string loc * module_type) list -> signature_item - val modtype: ?loc:Location.t -> string loc -> modtype_declaration -> signature_item - val open_: ?loc:Location.t -> override_flag -> Longident.t loc -> signature_item + val rec_module: + ?loc:Location.t -> (string loc * module_type) list -> signature_item + val modtype: + ?loc:Location.t -> string loc -> modtype_declaration -> signature_item + val open_: + ?loc:Location.t -> override_flag -> Longident.t loc -> signature_item val include_: ?loc:Location.t -> module_type -> signature_item val class_: ?loc:Location.t -> class_description list -> signature_item - val class_type: ?loc:Location.t -> class_type_declaration list -> signature_item + val class_type: + ?loc:Location.t -> class_type_declaration list -> signature_item val map_signature_item: mapper -> signature_item -> signature_item end diff --git a/stdlib/.depend b/stdlib/.depend index b8a837dbef..326959e43a 100644 --- a/stdlib/.depend +++ b/stdlib/.depend @@ -116,10 +116,10 @@ pervasives.cmo : pervasives.cmi pervasives.cmx : pervasives.cmi printexc.cmo : printf.cmi obj.cmi buffer.cmi array.cmi printexc.cmi printexc.cmx : printf.cmx obj.cmx buffer.cmx array.cmx printexc.cmi -printf.cmo : string.cmi pervasives.cmi obj.cmi list.cmi char.cmi buffer.cmi \ - array.cmi printf.cmi -printf.cmx : string.cmx pervasives.cmx obj.cmx list.cmx char.cmx buffer.cmx \ - array.cmx printf.cmi +printf.cmo : string.cmi obj.cmi list.cmi char.cmi buffer.cmi array.cmi \ + printf.cmi +printf.cmx : string.cmx obj.cmx list.cmx char.cmx buffer.cmx array.cmx \ + printf.cmi queue.cmo : obj.cmi queue.cmi queue.cmx : obj.cmx queue.cmi random.cmo : string.cmi pervasives.cmi nativeint.cmi int64.cmi int32.cmi \ @@ -226,10 +226,10 @@ pervasives.cmo : pervasives.cmi pervasives.p.cmx : pervasives.cmi printexc.cmo : printf.cmi obj.cmi buffer.cmi array.cmi printexc.cmi printexc.p.cmx : printf.p.cmx obj.p.cmx buffer.p.cmx array.p.cmx printexc.cmi -printf.cmo : string.cmi pervasives.cmi obj.cmi list.cmi char.cmi buffer.cmi \ - array.cmi printf.cmi -printf.p.cmx : string.p.cmx pervasives.p.cmx obj.p.cmx list.p.cmx char.p.cmx buffer.p.cmx \ - array.p.cmx printf.cmi +printf.cmo : string.cmi obj.cmi list.cmi char.cmi buffer.cmi array.cmi \ + printf.cmi +printf.p.cmx : string.p.cmx obj.p.cmx list.p.cmx char.p.cmx buffer.p.cmx array.p.cmx \ + printf.cmi queue.cmo : obj.cmi queue.cmi queue.p.cmx : obj.p.cmx queue.cmi random.cmo : string.cmi pervasives.cmi nativeint.cmi int64.cmi int32.cmi \ diff --git a/stdlib/Compflags b/stdlib/Compflags index 283c7402fd..707487fd02 100755 --- a/stdlib/Compflags +++ b/stdlib/Compflags @@ -16,6 +16,8 @@ case $1 in pervasives.cm[iox]|pervasives.p.cmx) echo ' -nopervasives';; camlinternalOO.cmi) echo ' -nopervasives';; camlinternalOO.cmx|camlinternalOO.p.cmx) echo ' -inline 0';; + buffer.cmx|buffer.p.cmx) echo ' -inline 3';; + # make sure add_char is inlined (PR#5872) buffer.cm[io]|printf.cm[io]|format.cm[io]|scanf.cm[io]) echo ' -w A';; scanf.cmx|scanf.p.cmx) echo ' -inline 9';; arrayLabels.cm[ox]|arrayLabels.p.cmx) echo ' -nolabels';; diff --git a/stdlib/pervasives.ml b/stdlib/pervasives.ml index 1640c203df..61fab1e0f3 100644 --- a/stdlib/pervasives.ml +++ b/stdlib/pervasives.ml @@ -24,7 +24,7 @@ exception Exit (* Composition operators *) -external (|>) : 'a -> ('a -> 'b) -> 'b = "%revapply" +external ( |> ) : 'a -> ('a -> 'b) -> 'b = "%revapply" external ( @@ ) : ('a -> 'b) -> 'a -> 'b = "%apply" (* Comparisons *) diff --git a/stdlib/pervasives.mli b/stdlib/pervasives.mli index ea92cf89fd..bab296a466 100644 --- a/stdlib/pervasives.mli +++ b/stdlib/pervasives.mli @@ -36,7 +36,7 @@ val failwith : string -> 'a exception Exit (** The [Exit] exception is not raised by any library function. It is - provided for use in your programs.*) + provided for use in your programs. *) (** {6 Comparisons} *) @@ -138,7 +138,7 @@ external ( or ) : bool -> bool -> bool = "%sequor" (** {6 Composition operators} *) -external (|>) : 'a -> ('a -> 'b) -> 'b = "%revapply" +external ( |> ) : 'a -> ('a -> 'b) -> 'b = "%revapply" (** Reverse-application operator: [x |> f |> g] is exactly equivalent to [g (f (x))]. @since 4.01 @@ -625,8 +625,7 @@ val open_out : string -> out_channel (** Open the named file for writing, and return a new output channel on that file, positionned at the beginning of the file. The file is truncated to zero length if it already exists. It - is created if it does not already exists. - Raise [Sys_error] if the file could not be opened. *) + is created if it does not already exists. *) val open_out_bin : string -> out_channel (** Same as {!Pervasives.open_out}, but the file is opened in binary mode, @@ -726,8 +725,7 @@ val set_binary_mode_out : out_channel -> bool -> unit val open_in : string -> in_channel (** Open the named file for reading, and return a new input channel - on that file, positionned at the beginning of the file. - Raise [Sys_error] if the file could not be opened. *) + on that file, positionned at the beginning of the file. *) val open_in_bin : string -> in_channel (** Same as {!Pervasives.open_in}, but the file is opened in binary mode, @@ -816,8 +814,7 @@ val close_in : in_channel -> unit (** Close the given channel. Input functions raise a [Sys_error] exception when they are applied to a closed input channel, except [close_in], which does nothing when applied to an already - closed channel. Note that [close_in] may raise [Sys_error] if - the operating system signals an error. *) + closed channel. *) val close_in_noerr : in_channel -> unit (** Same as [close_in], but ignore all errors. *) diff --git a/stdlib/printexc.ml b/stdlib/printexc.ml index a36e2d4e34..3324f6c4fa 100644 --- a/stdlib/printexc.ml +++ b/stdlib/printexc.ml @@ -165,3 +165,6 @@ external backtrace_status: unit -> bool = "caml_backtrace_status" let register_printer fn = printers := fn :: !printers + + +external get_callstack: int -> raw_backtrace = "caml_get_current_callstack" diff --git a/stdlib/printexc.mli b/stdlib/printexc.mli index b653265521..773fed814e 100644 --- a/stdlib/printexc.mli +++ b/stdlib/printexc.mli @@ -11,7 +11,7 @@ (* *) (***********************************************************************) -(** Facilities for printing exceptions. *) +(** Facilities for printing exceptions and inspecting current call stack. *) val to_string: exn -> string (** [Printexc.to_string e] returns a string representation of @@ -99,3 +99,16 @@ type raw_backtrace val get_raw_backtrace: unit -> raw_backtrace val print_raw_backtrace: out_channel -> raw_backtrace -> unit val raw_backtrace_to_string: raw_backtrace -> string + + +(** {6 Current call stack} *) + +val get_callstack: int -> raw_backtrace + +(** [Printexc.get_callstack n] returns a description of the top of the + call stack on the current program point (for the current thread), + with at most [n] entries. (Note: this function is not related to + exceptions at all, despite being part of the [Printexc] module.) + + @since 4.01.0 +*) diff --git a/stdlib/printf.ml b/stdlib/printf.ml index 2fa14bbfc6..3801692047 100644 --- a/stdlib/printf.ml +++ b/stdlib/printf.ml @@ -454,10 +454,13 @@ let format_float_lexeme = valid_float_loop 0 in (fun sfmt x -> - let s = format_float sfmt x in match classify_float x with - | FP_normal | FP_subnormal | FP_zero -> make_valid_float_lexeme s - | FP_nan | FP_infinite -> s) + | FP_normal | FP_subnormal | FP_zero -> + make_valid_float_lexeme (format_float sfmt x) + | FP_infinite -> + if x < 0.0 then "neg_infinity" else "infinity" + | FP_nan -> + "nan") ;; (* Decode a format string and act on it. @@ -540,8 +543,11 @@ let scan_format fmt args n pos cont_s cont_a cont_t cont_f cont_m = | 'F' as conv -> let (x : float) = get_arg spec n in let s = - if widths = [] then Pervasives.string_of_float x else - format_float_lexeme (extract_format_float conv fmt pos i widths) x in + format_float_lexeme + (if widths = [] + then "%.12g" + else extract_format_float conv fmt pos i widths) + x in cont_s (next_index spec n) s (succ i) | 'B' | 'b' -> let (x : bool) = get_arg spec n in diff --git a/stdlib/queue.ml b/stdlib/queue.ml index 6d82d25933..fb920d8c9c 100644 --- a/stdlib/queue.ml +++ b/stdlib/queue.ml @@ -107,14 +107,15 @@ let copy q = next = tail' } in - let rec copy cell = - if cell == tail then tail' - else { + let rec copy prev cell = + if cell != tail + then let res = { content = cell.content; - next = copy cell.next - } in + next = tail' + } in prev.next <- res; + copy res cell.next in - tail'.next <- copy tail.next; + copy tail' tail.next; { length = q.length; tail = tail' diff --git a/stdlib/queue.mli b/stdlib/queue.mli index 354271237d..55e8988329 100644 --- a/stdlib/queue.mli +++ b/stdlib/queue.mli @@ -14,6 +14,10 @@ (** First-in first-out queues. This module implements queues (FIFOs), with in-place modification. + + {b Warning} This module is not thread-safe: each {!Queue.t} value + must be protected from concurrent access (e.g. with a {!Mutex.t}). + Failure to do so can lead to a crash. *) type 'a t diff --git a/stdlib/stream.ml b/stdlib/stream.ml index 99d4bb22ce..753bce0056 100644 --- a/stdlib/stream.ml +++ b/stdlib/stream.ml @@ -19,8 +19,8 @@ type 'a t = { count : int; data : 'a data } and 'a data = Sempty | Scons of 'a * 'a data - | Sapp of 'a data * 'a t - | Slazy of 'a t Lazy.t + | Sapp of 'a data * 'a data + | Slazy of 'a data Lazy.t | Sgen of 'a gen | Sbuffio of buffio and 'a gen = { mutable curr : 'a option option; func : int -> 'a option } @@ -40,37 +40,26 @@ let fill_buff b = b.len <- input b.ic b.buff 0 (String.length b.buff); b.ind <- 0 ;; -let rec get_data s d = match d with - (* Only return a "forced stream", that is either Sempty or - Scons(a,_). If d is a generator or a buffer, the item a is seen as - extracted from the generator/buffer. - - Forcing also updates the "count" field of the delayed stream, - in the Sapp and Slazy cases (see slazy/lapp implementation below). *) +let rec get_data count d = match d with + (* Returns either Sempty or Scons(a, _) even when d is a generator + or a buffer. In those cases, the item a is seen as extracted from + the generator/buffer. + The count parameter is used for calling `Sgen-functions'. *) Sempty | Scons (_, _) -> d - | Sapp (d1, s2) -> - begin match get_data s d1 with - Scons (a, d11) -> Scons (a, Sapp (d11, s2)) - | Sempty -> - set_count s s2.count; - get_data s s2.data + | Sapp (d1, d2) -> + begin match get_data count d1 with + Scons (a, d11) -> Scons (a, Sapp (d11, d2)) + | Sempty -> get_data count d2 | _ -> assert false end - | Sgen {curr = Some None; _ } -> Sempty - | Sgen ({curr = Some(Some a); _ } as g) -> + | Sgen {curr = Some None; func = _ } -> Sempty + | Sgen ({curr = Some(Some a); func = f} as g) -> g.curr <- None; Scons(a, d) - | Sgen ({curr = None; _} as g) -> - (* Warning: anyone using g thinks that an item has been read *) - begin match g.func s.count with + | Sgen g -> + begin match g.func count with None -> g.curr <- Some(None); Sempty - | Some a -> - (* One must not update g.curr here, because there Scons(a,d) - result of get_data, if the outer stream s was a Sapp, will - be used to update the outer stream to Scons(a,s): there is - already a memoization process at the outer layer. If g.curr - was updated here, the saved element would be produced twice, - once by the outer layer, once by Sgen/g.curr. *) - Scons(a, d) + | Some a -> Scons(a, d) + (* Warning: anyone using g thinks that an item has been read *) end | Sbuffio b -> if b.ind >= b.len then fill_buff b; @@ -78,10 +67,7 @@ let rec get_data s d = match d with let r = Obj.magic (String.unsafe_get b.buff b.ind) in (* Warning: anyone using g thinks that an item has been read *) b.ind <- succ b.ind; Scons(r, d) - | Slazy f -> - let s2 = Lazy.force f in - set_count s s2.count; - get_data s s2.data + | Slazy f -> get_data count (Lazy.force f) ;; let rec peek s = @@ -90,20 +76,14 @@ let rec peek s = Sempty -> None | Scons (a, _) -> Some a | Sapp (_, _) -> - begin match get_data s s.data with - | Scons(a, _) as d -> set_data s d; Some a + begin match get_data s.count s.data with + Scons(a, _) as d -> set_data s d; Some a | Sempty -> None | _ -> assert false end - | Slazy f -> - let s2 = Lazy.force f in - set_count s s2.count; - set_data s s2.data; - peek s - | Sgen {curr = Some a; _ } -> a - | Sgen ({curr = None; _ } as g) -> - let x = g.func s.count in - g.curr <- Some x; x + | Slazy f -> set_data s (Lazy.force f); peek s + | Sgen {curr = Some a} -> a + | Sgen g -> let x = g.func s.count in g.curr <- Some x; x | Sbuffio b -> if b.ind >= b.len then fill_buff b; if b.len == 0 then begin set_data s Sempty; None end @@ -165,7 +145,18 @@ let of_list l = ;; let of_string s = - from (fun c -> if c < String.length s then Some s.[c] else None) + let count = ref 0 in + from (fun _ -> + (* We cannot use the index passed by the [from] function directly + because it returns the current stream count, with absolutely no + guarantee that it will start from 0. For example, in the case + of [Stream.icons 'c' (Stream.from_string "ab")], the first + access to the string will be made with count [1] already. + *) + let c = !count in + if c < String.length s + then (incr count; Some s.[c]) + else None) ;; let of_channel ic = @@ -175,21 +166,18 @@ let of_channel ic = (* Stream expressions builders *) -(* In the slazy and lapp case, we can't statically predict the value - of the "count" field. We put a dummy 0 value, which will be updated - when the parameter stream is forced (see update code in [get_data] - and [peek]). *) - +let iapp i s = {count = 0; data = Sapp (i.data, s.data)};; +let icons i s = {count = 0; data = Scons (i, s.data)};; let ising i = {count = 0; data = Scons (i, Sempty)};; -let icons i s = {count = s.count - 1; data = Scons (i, s.data)};; -let iapp i s = {count = i.count; data = Sapp (i.data, s)};; -let sempty = {count = 0; data = Sempty};; -let slazy f = {count = 0; data = Slazy (lazy (f()))};; +let lapp f s = + {count = 0; data = Slazy (lazy(Sapp ((f ()).data, s.data)))} +;; +let lcons f s = {count = 0; data = Slazy (lazy(Scons (f (), s.data)))};; +let lsing f = {count = 0; data = Slazy (lazy(Scons (f (), Sempty)))};; -let lsing f = {count = 0; data = Slazy (lazy (ising (f())))};; -let lcons f s = {count = 0; data = Slazy (lazy (icons (f()) s))};; -let lapp f s = {count = 0; data = Slazy (lazy(iapp (f()) s))};; +let sempty = {count = 0; data = Sempty};; +let slazy f = {count = 0; data = Slazy (lazy(f ()).data)};; (* For debugging use *) @@ -209,11 +197,11 @@ and dump_data f = print_string ", "; dump_data f d; print_string ")" - | Sapp (d1, s2) -> + | Sapp (d1, d2) -> print_string "Sapp ("; dump_data f d1; print_string ", "; - dump f s2; + dump_data f d2; print_string ")" | Slazy _ -> print_string "Slazy" | Sgen _ -> print_string "Sgen" diff --git a/stdlib/stream.mli b/stdlib/stream.mli index 1098a27650..aeb0da1e87 100644 --- a/stdlib/stream.mli +++ b/stdlib/stream.mli @@ -32,7 +32,12 @@ val from : (int -> 'a option) -> 'a t To create a new stream element, the function [f] is called with the current stream count. The user function [f] must return either [Some <value>] for a value or [None] to specify the end of the - stream. *) + stream. + + Do note that the indices passed to [f] may not start at [0] in the + general case. For example, [[< '0; '1; Stream.from f >]] would call + [f] the first time with count [2]. +*) val of_list : 'a list -> 'a t (** Return the stream holding the elements of the list in the same diff --git a/testsuite/external/.ignore b/testsuite/external/.ignore index 9e5691ac79..a65ca6ca85 100644 --- a/testsuite/external/.ignore +++ b/testsuite/external/.ignore @@ -12,7 +12,7 @@ advi-1.10.2 altergo alt-ergo-0.95 binprot -bin_prot-109.09.00 +bin_prot-109.30.00 bitstring ocaml-bitstring-2.0.3 boomerang @@ -24,13 +24,13 @@ camlimages-4.0.1 camlpdf camlpdf-0.5 camlp5 -camlp5-6.08 +camlp5-6.10 camlzip camlzip-1.04 camomile camomile-0.8.4 comparelib -comparelib-109.09.00 +comparelib-109.15.00 compcert compcert-1.13 configfile @@ -38,11 +38,15 @@ config-file-1.1 coq coq-8.4pl1 core -core-109.09.00 +core-109.37.00 coreextended -core_extended-109.09.00 +core_extended-109.36.00 +corekernel +core_kernel-109.37.00 cryptokit cryptokit-1.6 +customprintf +custom_printf-109.27.00 dbm camldbm-1.0 expect @@ -50,7 +54,7 @@ ocaml-expect-0.0.3 extlib extlib-1.5.2 fieldslib -fieldslib-109.09.00 +fieldslib-109.15.00 fileutils ocaml-fileutils-0.4.4 findlib @@ -59,8 +63,10 @@ framac frama-c-Oxygen-20120901 geneweb gw-6.05-src +herelib +herelib-109.35.00 hevea -hevea-2.00 +hevea-2.09 kaputt kaputt-1.2 lablgtk @@ -104,27 +110,31 @@ omake-0.9.8.6 ounit ounit-1.1.2 paounit -pa_ounit-109.09.00 +pa_ounit-109.36.00 pcre pcre-ocaml-6.2.5 pipebang -pipebang-109.09.00 +pipebang-109.28.00 react react-0.9.3 res res-3.2.0 +rss +ocamlrss-2.2.2 sexplib -sexplib-109.09.00 +sexplib-109.15.00 sks sks-1.1.3 sqlite sqlite3-ocaml-2.0.1 +textutils +textutils-109.36.00 typeconv -type_conv-109.09.00 +type_conv-109.28.00 unison unison-2.45.4 variantslib -variantslib-109.09.00 +variantslib-109.15.00 vsyml vsyml-2010-04-06 xmllight diff --git a/testsuite/external/Makefile b/testsuite/external/Makefile index 045e23869b..5fcd005ba4 100644 --- a/testsuite/external/Makefile +++ b/testsuite/external/Makefile @@ -31,6 +31,7 @@ default: @printf "\n\n########## Starting make at " >>log-${VERSION} @date >>log-${VERSION} ${MAKE} platform >>log-${VERSION} 2>&1 + @printf '\n' mv log-${VERSION} log_${VERSION}_`date -u '+%Y-%m-%d:%H:%M:%S'` # Platform-dependent subsets: add your own here. @@ -94,8 +95,9 @@ lablgtk: ${LABLGTK}.tar.gz findlib # TODO: add lablgl ${MAKE} world && \ ocamlfind remove lablgtk2 && \ ${MAKE} install && \ - ln -h -f -s ${PREFIX}/lib/ocaml/site-lib/lablgtk2 \ - ${PREFIX}/lib/ocaml/lablgtk2 ) + rm -f ${PREFIX}/lib/ocaml/lablgtk2 && \ + ln -f -s ${PREFIX}/lib/ocaml/site-lib/lablgtk2 \ + ${PREFIX}/lib/ocaml/lablgtk2 ) echo ${VERSION} >$@ clean:: rm -rf ${LABLGTK} lablgtk @@ -199,10 +201,10 @@ all: pcre ## Jane Street Core -# https://ocaml.janestreet.com/ocaml-core/109.09.00/individual/ -TYPECONV=type_conv-109.09.00 +# https://ocaml.janestreet.com/ocaml-core/109.28.00/individual/ +TYPECONV=type_conv-109.28.00 ${TYPECONV}.tar.gz: - ${WGET} https://ocaml.janestreet.com/ocaml-core/109.09.00/individual/$@ + ${WGET} https://ocaml.janestreet.com/ocaml-core/109.28.00/individual/$@ typeconv: ${TYPECONV}.tar.gz findlib printf "%s " "$@" >/dev/tty test -d ${PREFIX} @@ -222,10 +224,10 @@ distclean:: rm -f ${TYPECONV}.tar.gz all: typeconv -# https://ocaml.janestreet.com/ocaml-core/109.09.00/individual/ -VARIANTSLIB=variantslib-109.09.00 +# https://ocaml.janestreet.com/ocaml-core/109.15.00/individual/ +VARIANTSLIB=variantslib-109.15.00 ${VARIANTSLIB}.tar.gz: - ${WGET} https://ocaml.janestreet.com/ocaml-core/109.09.00/individual/$@ + ${WGET} https://ocaml.janestreet.com/ocaml-core/109.15.00/individual/$@ variantslib: ${VARIANTSLIB}.tar.gz findlib typeconv printf "%s " "$@" >/dev/tty test -d ${PREFIX} @@ -245,10 +247,10 @@ distclean:: rm -f ${VARIANTSLIB}.tar.gz all: variantslib -# https://ocaml.janestreet.com/ocaml-core/109.09.00/individual/ -PIPEBANG=pipebang-109.09.00 +# https://ocaml.janestreet.com/ocaml-core/109.28.00/individual/ +PIPEBANG=pipebang-109.28.00 ${PIPEBANG}.tar.gz: - ${WGET} https://ocaml.janestreet.com/ocaml-core/109.09.00/individual/$@ + ${WGET} https://ocaml.janestreet.com/ocaml-core/109.28.00/individual/$@ pipebang: ${PIPEBANG}.tar.gz findlib typeconv printf "%s " "$@" >/dev/tty test -d ${PREFIX} @@ -268,10 +270,10 @@ distclean:: rm -f ${PIPEBANG}.tar.gz all: pipebang -# https://ocaml.janestreet.com/ocaml-core/109.09.00/individual/ -PAOUNIT=pa_ounit-109.09.00 +# https://ocaml.janestreet.com/ocaml-core/109.36.00/individual/ +PAOUNIT=pa_ounit-109.36.00 ${PAOUNIT}.tar.gz: - ${WGET} https://ocaml.janestreet.com/ocaml-core/109.09.00/individual/$@ + ${WGET} https://ocaml.janestreet.com/ocaml-core/109.36.00/individual/$@ paounit: ${PAOUNIT}.tar.gz findlib typeconv printf "%s " "$@" >/dev/tty test -d ${PREFIX} @@ -291,10 +293,10 @@ distclean:: rm -f ${PAOUNIT}.tar.gz all: paounit -# https://ocaml.janestreet.com/ocaml-core/109.09.00/individual/ -COMPARELIB=comparelib-109.09.00 +# https://ocaml.janestreet.com/ocaml-core/109.15.00/individual/ +COMPARELIB=comparelib-109.15.00 ${COMPARELIB}.tar.gz: - ${WGET} https://ocaml.janestreet.com/ocaml-core/109.09.00/individual/$@ + ${WGET} https://ocaml.janestreet.com/ocaml-core/109.15.00/individual/$@ comparelib: ${COMPARELIB}.tar.gz findlib typeconv printf "%s " "$@" >/dev/tty test -d ${PREFIX} @@ -314,10 +316,10 @@ distclean:: rm -f ${COMPARELIB}.tar.gz all: comparelib -# https://ocaml.janestreet.com/ocaml-core/109.09.00/individual/ -BINPROT=bin_prot-109.09.00 +# https://ocaml.janestreet.com/ocaml-core/109.30.00/individual/ +BINPROT=bin_prot-109.30.00 ${BINPROT}.tar.gz: - ${WGET} https://ocaml.janestreet.com/ocaml-core/109.09.00/individual/$@ + ${WGET} https://ocaml.janestreet.com/ocaml-core/109.30.00/individual/$@ binprot: ${BINPROT}.tar.gz findlib typeconv ounit printf "%s " "$@" >/dev/tty test -d ${PREFIX} @@ -337,10 +339,10 @@ distclean:: rm -f ${BINPROT}.tar.gz all: binprot -# https://ocaml.janestreet.com/ocaml-core/109.09.00/individual/ -FIELDSLIB=fieldslib-109.09.00 +# https://ocaml.janestreet.com/ocaml-core/109.15.00/individual/ +FIELDSLIB=fieldslib-109.15.00 ${FIELDSLIB}.tar.gz: - ${WGET} https://ocaml.janestreet.com/ocaml-core/109.09.00/individual/$@ + ${WGET} https://ocaml.janestreet.com/ocaml-core/109.15.00/individual/$@ fieldslib: ${FIELDSLIB}.tar.gz findlib typeconv printf "%s " "$@" >/dev/tty test -d ${PREFIX} @@ -360,10 +362,10 @@ distclean:: rm -f ${FIELDSLIB}.tar.gz all: fieldslib -# https://ocaml.janestreet.com/ocaml-core/109.09.00/individual/ -SEXPLIB=sexplib-109.09.00 +# https://ocaml.janestreet.com/ocaml-core/109.15.00/individual/ +SEXPLIB=sexplib-109.15.00 ${SEXPLIB}.tar.gz: - ${WGET} https://ocaml.janestreet.com/ocaml-core/109.09.00/individual/$@ + ${WGET} https://ocaml.janestreet.com/ocaml-core/109.15.00/individual/$@ sexplib: ${SEXPLIB}.tar.gz findlib typeconv printf "%s " "$@" >/dev/tty test -d ${PREFIX} @@ -383,12 +385,59 @@ distclean:: rm -f ${SEXPLIB}.tar.gz all: sexplib -# https://ocaml.janestreet.com/ocaml-core/109.09.00/individual/ -CORE=core-109.09.00 +# https://ocaml.janestreet.com/ocaml-core/109.35.00/individual/ +HERELIB=herelib-109.35.00 +${HERELIB}.tar.gz: + ${WGET} https://ocaml.janestreet.com/ocaml-core/109.35.00/individual/$@ +herelib: ${HERELIB}.tar.gz + printf "%s " "$@" >/dev/tty + test -d ${PREFIX} + rm -rf ${HERELIB} + tar zxf ${HERELIB}.tar.gz + ./Patcher.sh ${HERELIB} + ( cd ${HERELIB} && \ + export PATH=${PREFIX}/bin:$$PATH && \ + sh ./configure --prefix ${PREFIX} && \ + ${MAKE} && \ + ocamlfind remove herelib && \ + ${MAKE} install ) + echo ${VERSION} >$@ +clean:: + rm -rf ${HERELIB} herelib +distclean:: + rm -f ${HERELIB}.tar.gz +all: herelib + +# https://ocaml.janestreet.com/ocaml-core/109.37.00/individual/ +COREKERNEL=core_kernel-109.37.00 +${COREKERNEL}.tar.gz: + ${WGET} https://ocaml.janestreet.com/ocaml-core/109.37.00/individual/$@ +corekernel: ${COREKERNEL}.tar.gz findlib variantslib sexplib fieldslib \ + binprot comparelib paounit pipebang res ounit herelib + printf "%s " "$@" >/dev/tty + test -d ${PREFIX} + rm -rf ${COREKERNEL} + tar zxf ${COREKERNEL}.tar.gz + ./Patcher.sh ${COREKERNEL} + ( cd ${COREKERNEL} && \ + export PATH=${PREFIX}/bin:$$PATH && \ + ocaml setup.ml -configure && \ + ocaml setup.ml -build && \ + ocamlfind remove core_kernel && \ + ocaml setup.ml -install ) + echo ${VERSION} >$@ +clean:: + rm -rf ${COREKERNEL} corekernel +distclean:: + rm -f ${COREKERNEL}.tar.gz +all: core + +# https://ocaml.janestreet.com/ocaml-core/109.37.00/individual/ +CORE=core-109.37.00 ${CORE}.tar.gz: - ${WGET} https://ocaml.janestreet.com/ocaml-core/109.09.00/individual/$@ + ${WGET} https://ocaml.janestreet.com/ocaml-core/109.37.00/individual/$@ core: ${CORE}.tar.gz findlib variantslib sexplib fieldslib binprot comparelib \ - paounit pipebang res ounit + paounit pipebang res ounit corekernel printf "%s " "$@" >/dev/tty test -d ${PREFIX} rm -rf ${CORE} @@ -407,10 +456,56 @@ distclean:: rm -f ${CORE}.tar.gz all: core -# https://ocaml.janestreet.com/ocaml-core/109.09.00/individual/ -COREEXTENDED=core_extended-109.09.00 +# https://ocaml.janestreet.com/ocaml-core/109.27.00/individual/ +CUSTOMPRINTF=custom_printf-109.27.00 +${CUSTOMPRINTF}.tar.gz: + ${WGET} https://ocaml.janestreet.com/ocaml-core/109.27.00/individual/$@ +customprintf: ${CUSTOMPRINTF}.tar.gz + printf "%s " "$@" >/dev/tty + test -d ${PREFIX} + rm -rf ${CUSTOMPRINTF} + tar zxf ${CUSTOMPRINTF}.tar.gz + ./Patcher.sh ${CUSTOMPRINTF} + ( cd ${CUSTOMPRINTF} && \ + export PATH=${PREFIX}/bin:$$PATH && \ + sh ./configure --prefix ${PREFIX} && \ + ${MAKE} && \ + ocamlfind remove customprintf && \ + ${MAKE} install ) + echo ${VERSION} >$@ +clean:: + rm -rf ${CUSTOMPRINTF} customprintf +distclean:: + rm -f ${CUSTOMPRINTF}.tar.gz +all: customprintf + +# https://ocaml.janestreet.com/ocaml-core/109.36.00/individual/ +TEXTUTILS=textutils-109.36.00 +${TEXTUTILS}.tar.gz: + ${WGET} https://ocaml.janestreet.com/ocaml-core/109.36.00/individual/$@ +textutils: ${TEXTUTILS}.tar.gz + printf "%s " "$@" >/dev/tty + test -d ${PREFIX} + rm -rf ${TEXTUTILS} + tar zxf ${TEXTUTILS}.tar.gz + ./Patcher.sh ${TEXTUTILS} + ( cd ${TEXTUTILS} && \ + export PATH=${PREFIX}/bin:$$PATH && \ + sh ./configure --prefix ${PREFIX} && \ + ${MAKE} && \ + ocamlfind remove textutils && \ + ${MAKE} install ) + echo ${VERSION} >$@ +clean:: + rm -rf ${TEXTUTILS} textutils +distclean:: + rm -f ${TEXTUTILS}.tar.gz +all: textutils + +# https://ocaml.janestreet.com/ocaml-core/109.36.00/individual/ +COREEXTENDED=core_extended-109.36.00 ${COREEXTENDED}.tar.gz: - ${WGET} https://ocaml.janestreet.com/ocaml-core/109.09.00/individual/$@ + ${WGET} https://ocaml.janestreet.com/ocaml-core/109.36.00/individual/$@ coreextended: ${COREEXTENDED}.tar.gz findlib sexplib fieldslib binprot paounit \ pipebang core pcre res comparelib ounit printf "%s " "$@" >/dev/tty @@ -642,10 +737,10 @@ distclean:: rm -f ${OBROWSER}.tar.gz all: obrowser -# http://hevea.inria.fr/ -HEVEA=hevea-2.00 +# http://hevea.inria.fr/old/ +HEVEA=hevea-2.09 ${HEVEA}.tar.gz: - ${WGET} http://hevea.inria.fr/distri/$@ + ${WGET} http://hevea.inria.fr/old/$@ hevea: ${HEVEA}.tar.gz printf "%s " "$@" >/dev/tty test -d ${PREFIX} @@ -746,6 +841,7 @@ xmllight: ${XMLLIGHT}.zip ./Patcher.sh ${XMLLIGHT} ( cd ${XMLLIGHT} && \ export PATH=${PREFIX}/bin:$$PATH && \ + ${MAKE} xml_parser.ml && \ ${MAKE} all opt && \ ${MAKE} install ) echo ${VERSION} >$@ @@ -782,7 +878,7 @@ all: configfile XMLM=xmlm-1.1.0 ${XMLM}.tbz: ${WGET} http://erratique.ch/software/xmlm/releases/$@ -xmlm: ${XMLM}.tbz +xmlm: ${XMLM}.tbz findlib printf "%s " "$@" >/dev/tty test -d ${PREFIX} rm -rf ${XMLM} @@ -790,7 +886,7 @@ xmlm: ${XMLM}.tbz ./Patcher.sh ${XMLM} oasis-common.patch ( cd ${XMLM} && \ export PATH=${PREFIX}/bin:$$PATH && \ - ocaml setup.ml -configure && \ + ocaml setup.ml -configure --prefix ${PREFIX} && \ ocaml setup.ml -build && \ ocamlfind remove xmlm && \ ocaml setup.ml -install ) @@ -1016,6 +1112,28 @@ distclean:: rm -f ${OCAMLNET}.tar.gz all: ocamlnet +# http://zoggy.github.io/ocamlrss/ +RSS=ocamlrss-2.2.2 +${RSS}.tar.gz: + ${WGET} http://zoggy.github.io/ocamlrss/$@ +rss: ${RSS}.tar.gz xmlm ocamlnet + printf "%s " "$@" >/dev/tty + test -d ${PREFIX} + rm -rf ${RSS} + tar zxf ${RSS}.tar.gz + ./Patcher.sh ${RSS} + ( cd ${RSS} && \ + export PATH=${PREFIX}/bin:$$PATH && \ + ${MAKE} all && \ + ocamlfind remove ocaml-rss && \ + ${MAKE} install ) + echo ${VERSION} >$@ +clean:: + rm -rf ${RSS} rss +distclean:: + rm -f ${RSS}.tar.gz +all: rss + # http://code.google.com/p/ocaml-extlib/ EXTLIB=extlib-1.5.2 ${EXTLIB}.tar.gz: @@ -1378,13 +1496,13 @@ camlpdf: ${CAMLPDF}.tar.bz2 ${MAKE} install ) echo ${VERSION} >$@ clean:: - rm -rf ${CAMLPDF} foo + rm -rf ${CAMLPDF} camlpdf distclean:: rm -f ${CAMLPDF}.tar.gz all: camlpdf # http://pauillac.inria.fr/~ddr/camlp5/ -CAMLP5=camlp5-6.08 +CAMLP5=camlp5-6.10 ${CAMLP5}.tgz: ${WGET} http://pauillac.inria.fr/~ddr/camlp5/distrib/src/$@ camlp5: ${CAMLP5}.tgz @@ -1536,7 +1654,7 @@ foo: ${FOO}.tar.gz export PATH=${PREFIX}/bin:$$PATH && \ sh ./configure --prefix ${PREFIX} && \ ${MAKE} && \ - ocamlfind remove foo \ + ocamlfind remove foo && \ ${MAKE} install ) echo ${VERSION} >$@ xxclean:: diff --git a/testsuite/external/camlp5-6.10.patch b/testsuite/external/camlp5-6.10.patch new file mode 100644 index 0000000000..eeaf4c41b3 --- /dev/null +++ b/testsuite/external/camlp5-6.10.patch @@ -0,0 +1,10 @@ +--- camlp5-6.10.orig/ocaml_stuff/4.01.0/utils/warnings.mli 2013-06-19 04:17:42.000000000 +0200 ++++ camlp5-6.10/ocaml_stuff/4.01.0/utils/warnings.mli 2013-08-13 16:14:47.000000000 +0200 +@@ -58,6 +58,7 @@ + | Nonoptional_label of string (* 43 *) + | Open_shadow_identifier of string * string (* 44 *) + | Open_shadow_label_constructor of string * string (* 45 *) ++ | Bad_env_variable of string * string + ;; + + val parse_options : bool -> string -> unit;; diff --git a/testsuite/external/core-109.37.00.patch b/testsuite/external/core-109.37.00.patch new file mode 100644 index 0000000000..53e443ee66 --- /dev/null +++ b/testsuite/external/core-109.37.00.patch @@ -0,0 +1,20 @@ +--- core-109.37.00.orig/lib/core_unix.ml 2013-08-06 21:52:16.000000000 +0200 ++++ core-109.37.00/lib/core_unix.ml 2013-08-13 15:25:11.000000000 +0200 +@@ -890,6 +890,7 @@ + | O_SYNC + | O_RSYNC + | O_SHARE_DELETE ++| O_CLOEXEC + with sexp + + type file_perm = int with of_sexp +--- core-109.37.00.orig/lib/core_unix.mli 2013-08-06 21:52:16.000000000 +0200 ++++ core-109.37.00/lib/core_unix.mli 2013-08-13 15:25:32.000000000 +0200 +@@ -305,6 +305,7 @@ + | O_SYNC (** Writes complete as `Synchronised I/O file integrity completion' *) + | O_RSYNC (** Reads complete as writes (depending on O_SYNC/O_DSYNC) *) + | O_SHARE_DELETE (** Windows only: allow the file to be deleted while still open *) ++ | O_CLOEXEC + with sexp + + (** The type of file access rights. *) diff --git a/testsuite/external/lwt-2.4.0.patch b/testsuite/external/lwt-2.4.0.patch new file mode 100644 index 0000000000..14ce097cb5 --- /dev/null +++ b/testsuite/external/lwt-2.4.0.patch @@ -0,0 +1,24 @@ +--- lwt-2.4.0.orig/src/unix/lwt_unix.ml 2012-07-19 13:35:56.000000000 +0200 ++++ lwt-2.4.0/src/unix/lwt_unix.ml 2013-08-13 15:46:12.000000000 +0200 +@@ -596,6 +596,9 @@ + #if ocaml_version >= (3, 13) + | O_SHARE_DELETE + #endif ++#if ocaml_version >= (4, 01) ++ | O_CLOEXEC ++#endif + + #if windows + +--- lwt-2.4.0.orig/src/unix/lwt_unix.mli 2012-07-19 13:35:56.000000000 +0200 ++++ lwt-2.4.0/src/unix/lwt_unix.mli 2013-08-13 15:46:18.000000000 +0200 +@@ -315,6 +315,9 @@ + #if ocaml_version >= (3, 13) + | O_SHARE_DELETE + #endif ++#if ocaml_version >= (4, 01) ++ | O_CLOEXEC ++#endif + + val openfile : string -> open_flag list -> file_perm -> file_descr Lwt.t + (** Wrapper for [Unix.openfile]. *) diff --git a/testsuite/external/obrowser-1.1.1.patch b/testsuite/external/obrowser-1.1.1.patch index f44bcc710f..e135f1d3fa 100644 --- a/testsuite/external/obrowser-1.1.1.patch +++ b/testsuite/external/obrowser-1.1.1.patch @@ -271,8 +271,721 @@ val rev_map : ('a -> 'b) -> 'a list -> 'b list (** [List.rev_map f l] gives the same result as {!List.rev}[ (]{!List.map}[ f l)], but is tail-recursive and +--- obrowser-1.1.1-old/rt/caml/pervasives.mli 2013-06-20 13:50:19.000000000 +0200 ++++ obrowser-1.1.1/rt/caml/pervasives.mli 2013-06-20 13:50:59.000000000 +0200 +@@ -11,8 +11,6 @@ + (* *) + (***********************************************************************) + +-(* $Id: pervasives.mli 10548 2010-06-09 10:26:19Z weis $ *) +- + (** The initially opened module. + + This module provides the basic operations over the built-in types +@@ -122,7 +120,7 @@ + (** The boolean negation. *) + + external ( && ) : bool -> bool -> bool = "%sequand" +-(** The boolean ``and''. Evaluation is sequential, left-to-right: ++(** The boolean 'and'. Evaluation is sequential, left-to-right: + in [e1 && e2], [e1] is evaluated first, and if it returns [false], + [e2] is not evaluated at all. *) + +@@ -130,7 +128,7 @@ + (** @deprecated {!Pervasives.( && )} should be used instead. *) + + external ( || ) : bool -> bool -> bool = "%sequor" +-(** The boolean ``or''. Evaluation is sequential, left-to-right: ++(** The boolean 'or'. Evaluation is sequential, left-to-right: + in [e1 || e2], [e1] is evaluated first, and if it returns [true], + [e2] is not evaluated at all. *) + +@@ -138,6 +136,20 @@ + (** @deprecated {!Pervasives.( || )} should be used instead.*) + + ++(** {6 Composition operators} *) ++ ++external ( |> ) : 'a -> ('a -> 'b) -> 'b = "%revapply" ++(** Reverse-application operator: [x |> f |> g] is exactly equivalent ++ to [g (f (x))]. ++ @since 4.01 ++*) ++ ++external ( @@ ) : ('a -> 'b) -> 'a -> 'b = "%apply" ++(** Application operator: [g @@ f @@ x] is exactly equivalent to ++ [g (f (x))]. ++ @since 4.01 ++*) ++ + (** {6 Integer arithmetic} *) + + (** Integers are 31 bits wide (or 63 bits on 64-bit processors). +@@ -234,7 +246,7 @@ + Floating-point operations never raise an exception on overflow, + underflow, division by zero, etc. Instead, special IEEE numbers + are returned as appropriate, such as [infinity] for [1.0 /. 0.0], +- [neg_infinity] for [-1.0 /. 0.0], and [nan] (``not a number'') ++ [neg_infinity] for [-1.0 /. 0.0], and [nan] ('not a number') + for [0.0 /. 0.0]. These special numbers then propagate through + floating-point computations as expected: for instance, + [1.0 /. infinity] is [0.0], and any arithmetic operation with [nan] +@@ -320,7 +332,7 @@ + of the hypotenuse of a right-angled triangle with sides of length + [x] and [y], or, equivalently, the distance of the point [(x,y)] + to origin. +- @since 3.13.0 *) ++ @since 4.00.0 *) + + external cosh : float -> float = "caml_cosh_float" "cosh" "float" + (** Hyperbolic cosine. Argument is in radians. *) +@@ -351,7 +363,7 @@ + and whose sign is that of [y]. If [x] is [nan], returns [nan]. + If [y] is [nan], returns either [x] or [-. x], but it is not + specified which. +- @since 3.13.0 *) ++ @since 4.00.0 *) + + external mod_float : float -> float -> float = "caml_fmod_float" "fmod" "float" + (** [mod_float a b] returns the remainder of [a] with respect to +@@ -395,7 +407,7 @@ + val nan : float + (** A special floating-point value denoting the result of an + undefined operation such as [0.0 /. 0.0]. Stands for +- ``not a number''. Any floating-point operation with [nan] as ++ 'not a number'. Any floating-point operation with [nan] as + argument returns [nan] as result. As for floating-point comparisons, + [=], [<], [<=], [>] and [>=] return [false] and [<>] returns [true] + if one or both of their arguments is [nan]. *) +@@ -461,7 +473,9 @@ + (** {6 String conversion functions} *) + + val string_of_bool : bool -> string +-(** Return the string representation of a boolean. *) ++(** Return the string representation of a boolean. As the returned values ++ may be shared, the user should not modify them directly. ++*) + + val bool_of_string : string -> bool + (** Convert the given string to a boolean. +@@ -506,7 +520,9 @@ + (** List concatenation. *) + + +-(** {6 Input/output} *) ++(** {6 Input/output} ++ Note: all input/output functions can raise [Sys_error] when the system ++ calls they invoke fail. *) + + type in_channel + (** The type of input channel. *) +@@ -864,23 +880,73 @@ + + (** {6 Operations on format strings} *) + +-(** Format strings are used to read and print data using formatted input +- functions in module {!Scanf} and formatted output in modules {!Printf} and +- {!Format}. *) ++(** Format strings are character strings with special lexical conventions ++ that defines the functionality of formatted input/output functions. Format ++ strings are used to read data with formatted input functions from module ++ {!Scanf} and to print data with formatted output functions from modules ++ {!Printf} and {!Format}. ++ ++ Format strings are made of three kinds of entities: ++ - {e conversions specifications}, introduced by the special character ['%'] ++ followed by one or more characters specifying what kind of argument to ++ read or print, ++ - {e formatting indications}, introduced by the special character ['@'] ++ followed by one or more characters specifying how to read or print the ++ argument, ++ - {e plain characters} that are regular characters with usual lexical ++ conventions. Plain characters specify string literals to be read in the ++ input or printed in the output. ++ ++ There is an additional lexical rule to escape the special characters ['%'] ++ and ['@'] in format strings: if a special character follows a ['%'] ++ character, it is treated as a plain character. In other words, ["%%"] is ++ considered as a plain ['%'] and ["%@"] as a plain ['@']. ++ ++ For more information about conversion specifications and formatting ++ indications available, read the documentation of modules {!Scanf}, ++ {!Printf} and {!Format}. ++*) + + (** Format strings have a general and highly polymorphic type + [('a, 'b, 'c, 'd, 'e, 'f) format6]. Type [format6] is built in. + The two simplified types, [format] and [format4] below are +- included for backward compatibility with earlier releases of OCaml. +- ['a] is the type of the parameters of the format, +- ['b] is the type of the first argument given to +- [%a] and [%t] printing functions, +- ['c] is the type of the argument transmitted to the first argument of +- "kprintf"-style functions, +- ['d] is the result type for the "scanf"-style functions, +- ['e] is the type of the receiver function for the "scanf"-style functions, +- ['f] is the result type for the "printf"-style function. +- *) ++ included for backward compatibility with earlier releases of ++ OCaml. ++ ++ The meaning of format string type parameters is as follows: ++ ++ - ['a] is the type of the parameters of the format for formatted output ++ functions ([printf]-style functions); ++ ['a] is the type of the values read by the format for formatted input ++ functions ([scanf]-style functions). ++ ++ - ['b] is the type of input source for formatted input functions and the ++ type of output target for formatted output functions. ++ For [printf]-style functions from module [Printf], ['b] is typically ++ [out_channel]; ++ for [printf]-style functions from module [Format], ['b] is typically ++ [Format.formatter]; ++ for [scanf]-style functions from module [Scanf], ['b] is typically ++ [Scanf.Scanning.in_channel]. ++ ++ Type argument ['b] is also the type of the first argument given to ++ user's defined printing functions for [%a] and [%t] conversions, ++ and user's defined reading functions for [%r] conversion. ++ ++ - ['c] is the type of the result of the [%a] and [%t] printing ++ functions, and also the type of the argument transmitted to the ++ first argument of [kprintf]-style functions or to the ++ [kscanf]-style functions. ++ ++ - ['d] is the type of parameters for the [scanf]-style functions. ++ ++ - ['e] is the type of the receiver function for the [scanf]-style functions. ++ ++ - ['f] is the final result type of a formatted input/output function ++ invocation: for the [printf]-style functions, it is typically [unit]; ++ for the [scanf]-style functions, it is typically the result type of the ++ receiver function. ++*) + type ('a, 'b, 'c, 'd) format4 = ('a, 'b, 'c, 'c, 'c, 'd) format6 + + type ('a, 'b, 'c) format = ('a, 'b, 'c, 'c) format4 +@@ -892,14 +958,22 @@ + ('a, 'b, 'c, 'd, 'e, 'f) format6 -> + ('a, 'b, 'c, 'd, 'e, 'f) format6 = "%identity" + (** [format_of_string s] returns a format string read from the string +- literal [s]. *) ++ literal [s]. ++ Note: [format_of_string] can not convert a string argument that is not a ++ literal. If you need this functionality, use the more general ++ {!Scanf.format_from_string} function. ++*) + + val ( ^^ ) : + ('a, 'b, 'c, 'd, 'e, 'f) format6 -> + ('f, 'b, 'c, 'e, 'g, 'h) format6 -> + ('a, 'b, 'c, 'd, 'g, 'h) format6 +-(** [f1 ^^ f2] catenates formats [f1] and [f2]. The result is a format +- that accepts arguments from [f1], then arguments from [f2]. *) ++(** [f1 ^^ f2] catenates format strings [f1] and [f2]. The result is a ++ format string that behaves as the concatenation of format strings [f1] and ++ [f2]: in case of formatted output, it accepts arguments from [f1], then ++ arguments from [f2]; in case of formatted input, it returns results from ++ [f1], then results from [f2]. ++*) + + + (** {6 Program termination} *) +@@ -918,13 +992,12 @@ + termination time. The functions registered with [at_exit] + will be called when the program executes {!Pervasives.exit}, + or terminates, either normally or because of an uncaught exception. +- The functions are called in ``last in, first out'' order: ++ The functions are called in 'last in, first out' order: + the function most recently added with [at_exit] is called first. *) + + (**/**) + +- +-(** {6 For system use only, not for the casual user} *) ++(* The following is for system use only. Do not call directly. *) + + val valid_float_lexem : string -> string + +--- obrowser-1.1.1-old/rt/caml/pervasives.ml 2013-06-20 13:50:19.000000000 +0200 ++++ obrowser-1.1.1/rt/caml/pervasives.ml 2013-06-20 13:51:53.000000000 +0200 +@@ -1,6 +1,6 @@ + (***********************************************************************) + (* *) +-(* Objective Caml *) ++(* OCaml *) + (* *) + (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) + (* *) +@@ -11,8 +11,6 @@ + (* *) + (***********************************************************************) + +-(* $Id: pervasives.ml 9412 2009-11-09 11:42:39Z weis $ *) +- + (* type 'a option = None | Some of 'a *) + + (* Exceptions *) +@@ -24,66 +22,70 @@ + + exception Exit + ++(* Composition operators *) ++ ++external ( |> ) : 'a -> ('a -> 'b) -> 'b = "%revapply" ++external ( @@ ) : ('a -> 'b) -> 'a -> 'b = "%apply" ++ + (* Comparisons *) + +-external (=) : 'a -> 'a -> bool = "%equal" +-external (<>) : 'a -> 'a -> bool = "%notequal" +-external (<) : 'a -> 'a -> bool = "%lessthan" +-external (>) : 'a -> 'a -> bool = "%greaterthan" +-external (<=) : 'a -> 'a -> bool = "%lessequal" +-external (>=) : 'a -> 'a -> bool = "%greaterequal" +-external compare: 'a -> 'a -> int = "%compare" ++external ( = ) : 'a -> 'a -> bool = "%equal" ++external ( <> ) : 'a -> 'a -> bool = "%notequal" ++external ( < ) : 'a -> 'a -> bool = "%lessthan" ++external ( > ) : 'a -> 'a -> bool = "%greaterthan" ++external ( <= ) : 'a -> 'a -> bool = "%lessequal" ++external ( >= ) : 'a -> 'a -> bool = "%greaterequal" ++external compare : 'a -> 'a -> int = "%compare" + + let min x y = if x <= y then x else y + let max x y = if x >= y then x else y + +-external (==) : 'a -> 'a -> bool = "%eq" +-external (!=) : 'a -> 'a -> bool = "%noteq" ++external ( == ) : 'a -> 'a -> bool = "%eq" ++external ( != ) : 'a -> 'a -> bool = "%noteq" + + (* Boolean operations *) + + external not : bool -> bool = "%boolnot" +-external (&) : bool -> bool -> bool = "%sequand" +-external (&&) : bool -> bool -> bool = "%sequand" +-external (or) : bool -> bool -> bool = "%sequor" +-external (||) : bool -> bool -> bool = "%sequor" ++external ( & ) : bool -> bool -> bool = "%sequand" ++external ( && ) : bool -> bool -> bool = "%sequand" ++external ( or ) : bool -> bool -> bool = "%sequor" ++external ( || ) : bool -> bool -> bool = "%sequor" + + (* Integer operations *) + +-external (~-) : int -> int = "%negint" +-external (~+) : int -> int = "%identity" ++external ( ~- ) : int -> int = "%negint" ++external ( ~+ ) : int -> int = "%identity" + external succ : int -> int = "%succint" + external pred : int -> int = "%predint" +-external (+) : int -> int -> int = "%addint" +-external (-) : int -> int -> int = "%subint" +-external ( * ) : int -> int -> int = "%mulint" +-external (/) : int -> int -> int = "%divint" +-external (mod) : int -> int -> int = "%modint" ++external ( + ) : int -> int -> int = "%addint" ++external ( - ) : int -> int -> int = "%subint" ++external ( * ) : int -> int -> int = "%mulint" ++external ( / ) : int -> int -> int = "%divint" ++external ( mod ) : int -> int -> int = "%modint" + + let abs x = if x >= 0 then x else -x + +-external (land) : int -> int -> int = "%andint" +-external (lor) : int -> int -> int = "%orint" +-external (lxor) : int -> int -> int = "%xorint" ++external ( land ) : int -> int -> int = "%andint" ++external ( lor ) : int -> int -> int = "%orint" ++external ( lxor ) : int -> int -> int = "%xorint" + + let lnot x = x lxor (-1) + +-external (lsl) : int -> int -> int = "%lslint" +-external (lsr) : int -> int -> int = "%lsrint" +-external (asr) : int -> int -> int = "%asrint" ++external ( lsl ) : int -> int -> int = "%lslint" ++external ( lsr ) : int -> int -> int = "%lsrint" ++external ( asr ) : int -> int -> int = "%asrint" + +-let min_int = 1 lsl (if 1 lsl 32 = 1 then 31 else 63) (* obrowser mod: no tag bit*) ++let min_int = 1 lsl (if 1 lsl 31 = 0 then 30 else 62) + let max_int = min_int - 1 + +- + (* Floating-point operations *) + +-external (~-.) : float -> float = "%negfloat" +-external (~+.) : float -> float = "%identity" +-external (+.) : float -> float -> float = "%addfloat" +-external (-.) : float -> float -> float = "%subfloat" ++external ( ~-. ) : float -> float = "%negfloat" ++external ( ~+. ) : float -> float = "%identity" ++external ( +. ) : float -> float -> float = "%addfloat" ++external ( -. ) : float -> float -> float = "%subfloat" + external ( *. ) : float -> float -> float = "%mulfloat" +-external (/.) : float -> float -> float = "%divfloat" ++external ( /. ) : float -> float -> float = "%divfloat" + external ( ** ) : float -> float -> float = "caml_power_float" "pow" "float" + external exp : float -> float = "caml_exp_float" "exp" "float" + external expm1 : float -> float = "caml_expm1_float" "caml_expm1" "float" +@@ -136,16 +138,16 @@ + | FP_zero + | FP_infinite + | FP_nan +-external classify_float: float -> fpclass = "caml_classify_float" ++external classify_float : float -> fpclass = "caml_classify_float" + + (* String operations -- more in module String *) + + external string_length : string -> int = "%string_length" +-external string_create: int -> string = "caml_create_string" ++external string_create : int -> string = "caml_create_string" + external string_blit : string -> int -> string -> int -> int -> unit + = "caml_blit_string" "noalloc" + +-let (^) s1 s2 = ++let ( ^ ) s1 s2 = + let l1 = string_length s1 and l2 = string_length s2 in + let s = string_create (l1 + l2) in + string_blit s1 0 s 0 l1; +@@ -170,8 +172,8 @@ + + (* String conversion functions *) + +-external format_int: string -> int -> string = "caml_format_int" +-external format_float: string -> float -> string = "caml_format_float" ++external format_int : string -> int -> string = "caml_format_int" ++external format_float : string -> float -> string = "caml_format_float" + + let string_of_bool b = + if b then "true" else "false" +@@ -187,7 +189,6 @@ + + module String = struct + external get : string -> int -> char = "%string_safe_get" +- external set : string -> int -> char -> unit = "%string_safe_set" + end + + let valid_float_lexem s = +@@ -195,7 +196,7 @@ + let rec loop i = + if i >= l then s ^ "." else + match s.[i] with +- | '0' .. '9' | '-' -> loop (i+1) ++ | '0' .. '9' | '-' -> loop (i + 1) + | _ -> s + in + loop 0 +@@ -207,7 +208,7 @@ + + (* List operations -- more in module List *) + +-let rec (@) l1 l2 = ++let rec ( @ ) l1 l2 = + match l1 with + [] -> l2 + | hd :: tl -> hd :: (tl @ l2) +@@ -217,12 +218,13 @@ + type in_channel + type out_channel + +-let open_descriptor_out _ = failwith "not implemented in obrowser" +-let open_descriptor_in _ = failwith "not implemented in obrowser" +- +-let stdin = Obj.magic 0 +-let stdout = Obj.magic 0 +-let stderr = Obj.magic 0 ++external open_descriptor_out : int -> out_channel ++ = "caml_ml_open_descriptor_out" ++external open_descriptor_in : int -> in_channel = "caml_ml_open_descriptor_in" ++ ++let stdin = open_descriptor_in 0 ++let stdout = open_descriptor_out 1 ++let stderr = open_descriptor_out 2 + + (* General output functions *) + +@@ -231,103 +233,184 @@ + | Open_creat | Open_trunc | Open_excl + | Open_binary | Open_text | Open_nonblock + +-let open_desc _ _ _ = failwith "not implemented in obrowser" +-let open_out_gen mode perm name = failwith "not implemented in obrowser" +-let open_out name = failwith "not implemented in obrowser" +-let open_out_bin name = failwith "not implemented in obrowser" +-let flush _ = failwith "not implemented in obrowser" +-let out_channels_list _ = failwith "not implemented in obrowser" +-let flush_all () = failwith "not implemented in obrowser" +-let unsafe_output _ _ _ _ = failwith "not implemented in obrowser" +-let output_char _ _ = failwith "not implemented in obrowser" +-let output_string oc s = failwith "not implemented in obrowser" +-let output oc s ofs len = failwith "not implemented in obrowser" +-let output_byte _ _ = failwith "not implemented in obrowser" +-let output_binary_int _ _ = failwith "not implemented in obrowser" +-let marshal_to_channel _ _ _ = failwith "not implemented in obrowser" +-let output_value _ _ = failwith "not implemented in obrowser" +-let seek_out _ _ = failwith "not implemented in obrowser" +-let pos_out _ = failwith "not implemented in obrowser" +-let out_channel_length _ = failwith "not implemented in obrowser" +-let close_out_channel _ = failwith "not implemented in obrowser" +-let close_out _ = failwith "not implemented in obrowser" +-let close_out_noerr _ = failwith "not implemented in obrowser" +-let set_binary_mode_out _ _ = failwith "not implemented in obrowser" ++external open_desc : string -> open_flag list -> int -> int = "caml_sys_open" ++ ++let open_out_gen mode perm name = ++ open_descriptor_out(open_desc name mode perm) ++ ++let open_out name = ++ open_out_gen [Open_wronly; Open_creat; Open_trunc; Open_text] 0o666 name ++ ++let open_out_bin name = ++ open_out_gen [Open_wronly; Open_creat; Open_trunc; Open_binary] 0o666 name ++ ++external flush : out_channel -> unit = "caml_ml_flush" ++ ++external out_channels_list : unit -> out_channel list ++ = "caml_ml_out_channels_list" ++ ++let flush_all () = ++ let rec iter = function ++ [] -> () ++ | a :: l -> (try flush a with _ -> ()); iter l ++ in iter (out_channels_list ()) ++ ++external unsafe_output : out_channel -> string -> int -> int -> unit ++ = "caml_ml_output" ++ ++external output_char : out_channel -> char -> unit = "caml_ml_output_char" ++ ++let output_string oc s = ++ unsafe_output oc s 0 (string_length s) ++ ++let output oc s ofs len = ++ if ofs < 0 || len < 0 || ofs > string_length s - len ++ then invalid_arg "output" ++ else unsafe_output 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" ++ ++external marshal_to_channel : out_channel -> 'a -> unit list -> unit ++ = "caml_output_value" ++let output_value chan v = marshal_to_channel chan v [] ++ ++external seek_out : out_channel -> int -> unit = "caml_ml_seek_out" ++external pos_out : out_channel -> int = "caml_ml_pos_out" ++external out_channel_length : out_channel -> int = "caml_ml_channel_size" ++external close_out_channel : out_channel -> unit = "caml_ml_close_channel" ++let close_out oc = flush oc; close_out_channel oc ++let close_out_noerr oc = ++ (try flush oc with _ -> ()); ++ (try close_out_channel oc with _ -> ()) ++external set_binary_mode_out : out_channel -> bool -> unit ++ = "caml_ml_set_binary_mode" + + (* General input functions *) + +-let open_in_gen _ _ _ = failwith "not implemented in obrowser" +-let open_in _ = failwith "not implemented in obrowser" +-let open_in_bin _ = failwith "not implemented in obrowser" +-let input_char _ = failwith "not implemented in obrowser" +-let unsafe_input _ _ _ _ = failwith "not implemented in obrowser" +-let input _ _ _ _ = failwith "not implemented in obrowser" +-let rec unsafe_really_input _ _ _ _ = failwith "not implemented in obrowser" +-let really_input _ _ _ _ = failwith "not implemented in obrowser" +-let input_scan_line _ = failwith "not implemented in obrowser" +-let input_line _ = failwith "not implemented in obrowser" +- +-let input_byte _ = failwith "not implemented in obrowser" +-let input_binary_int _ = failwith "not implemented in obrowser" +-let input_value _ = failwith "not implemented in obrowser" +-let seek_in _ _ = failwith "not implemented in obrowser" +-let pos_in _ = failwith "not implemented in obrowser" +-let in_channel_length _ = failwith "not implemented in obrowser" +-let close_in _ = failwith "not implemented in obrowser" +-let close_in_noerr _ = failwith "not implemented in obrowser" +-let set_binary_mode_in _ _ = failwith "not implemented in obrowser" ++let open_in_gen mode perm name = ++ open_descriptor_in(open_desc name mode perm) + +-(* Output functions on standard output *) ++let open_in name = ++ open_in_gen [Open_rdonly; Open_text] 0 name ++ ++let open_in_bin name = ++ open_in_gen [Open_rdonly; Open_binary] 0 name ++ ++external input_char : in_channel -> char = "caml_ml_input_char" ++ ++external unsafe_input : in_channel -> string -> int -> int -> int ++ = "caml_ml_input" ++ ++let input ic s ofs len = ++ if ofs < 0 || len < 0 || ofs > string_length s - len ++ then invalid_arg "input" ++ else unsafe_input ic s ofs len ++ ++let rec unsafe_really_input ic s ofs len = ++ if len <= 0 then () else begin ++ let r = unsafe_input ic s ofs len in ++ if r = 0 ++ then raise End_of_file ++ else unsafe_really_input ic s (ofs + r) (len - r) ++ end + +-external basic_io_write : string -> unit = "caml_basic_io_write" ++let really_input ic s ofs len = ++ if ofs < 0 || len < 0 || ofs > string_length s - len ++ then invalid_arg "really_input" ++ else unsafe_really_input ic s ofs len ++ ++external input_scan_line : in_channel -> int = "caml_ml_input_scan_line" ++ ++let input_line chan = ++ let rec build_result buf pos = function ++ [] -> buf ++ | hd :: tl -> ++ let len = string_length hd in ++ string_blit hd 0 buf (pos - len) len; ++ build_result buf (pos - len) tl in ++ let rec scan accu len = ++ let n = input_scan_line chan in ++ if n = 0 then begin (* n = 0: we are at EOF *) ++ match accu with ++ [] -> raise End_of_file ++ | _ -> build_result (string_create len) len accu ++ end else if n > 0 then begin (* n > 0: newline found in buffer *) ++ let res = string_create (n - 1) in ++ ignore (unsafe_input chan res 0 (n - 1)); ++ ignore (input_char chan); (* skip the newline *) ++ match accu with ++ [] -> res ++ | _ -> let len = len + n - 1 in ++ build_result (string_create len) len (res :: accu) ++ end else begin (* n < 0: newline not found *) ++ let beg = string_create (-n) in ++ ignore(unsafe_input chan beg 0 (-n)); ++ scan (beg :: accu) (len - n) ++ end ++ in scan [] 0 ++ ++external input_byte : in_channel -> int = "caml_ml_input_char" ++external input_binary_int : in_channel -> int = "caml_ml_input_int" ++external input_value : in_channel -> 'a = "caml_input_value" ++external seek_in : in_channel -> int -> unit = "caml_ml_seek_in" ++external pos_in : in_channel -> int = "caml_ml_pos_in" ++external in_channel_length : in_channel -> int = "caml_ml_channel_size" ++external close_in : in_channel -> unit = "caml_ml_close_channel" ++let close_in_noerr ic = (try close_in ic with _ -> ());; ++external set_binary_mode_in : in_channel -> bool -> unit ++ = "caml_ml_set_binary_mode" + +-let print_char c = basic_io_write (let s = string_create 1 in s.[0] <- c ; s) +-let print_string s = basic_io_write s +-let print_int i = basic_io_write (string_of_int i) +-let print_float f = basic_io_write (string_of_float f) ++(* Output functions on standard output *) ++ ++let print_char c = output_char stdout c ++let print_string s = output_string stdout s ++let print_int i = output_string stdout (string_of_int i) ++let print_float f = output_string stdout (string_of_float f) + let print_endline s = +- print_string s; print_char '\n' +-let print_newline () = print_char '\n' ++ output_string stdout s; output_char stdout '\n'; flush stdout ++let print_newline () = output_char stdout '\n'; flush stdout + + (* Output functions on standard error *) + +-let prerr_char c = basic_io_write (let s = string_create 1 in s.[0] <- c ; s) +-let prerr_string s = basic_io_write s +-let prerr_int i = basic_io_write (string_of_int i) +-let prerr_float f = basic_io_write (string_of_float f) ++let prerr_char c = output_char stderr c ++let prerr_string s = output_string stderr s ++let prerr_int i = output_string stderr (string_of_int i) ++let prerr_float f = output_string stderr (string_of_float f) + let prerr_endline s = +- prerr_string s; prerr_char '\n' +-let prerr_newline () = prerr_char '\n' ++ output_string stderr s; output_char stderr '\n'; flush stderr ++let prerr_newline () = output_char stderr '\n'; flush stderr + + (* Input functions on standard input *) + +-let read_line () = failwith "not implemented in obrowser" +-let read_int () = failwith "not implemented in obrowser" +-let read_float () = failwith "not implemented in obrowser" ++let read_line () = flush stdout; input_line stdin ++let read_int () = int_of_string(read_line()) ++let read_float () = float_of_string(read_line()) + + (* Operations on large files *) + + module LargeFile = + struct +- let seek_out _ _ = failwith "not implemented in obrowser" +- let pos_out _ = failwith "not implemented in obrowser" +- let out_channel_length _ = failwith "not implemented in obrowser" +- let seek_in _ _ = failwith "not implemented in obrowser" +- let pos_in _ = failwith "not implemented in obrowser" +- let in_channel_length _ = failwith "not implemented in obrowser" ++ external seek_out : out_channel -> int64 -> unit = "caml_ml_seek_out_64" ++ external pos_out : out_channel -> int64 = "caml_ml_pos_out_64" ++ external out_channel_length : out_channel -> int64 ++ = "caml_ml_channel_size_64" ++ external seek_in : in_channel -> int64 -> unit = "caml_ml_seek_in_64" ++ external pos_in : in_channel -> int64 = "caml_ml_pos_in_64" ++ external in_channel_length : in_channel -> int64 = "caml_ml_channel_size_64" + end + + (* References *) + +-type 'a ref = { mutable contents: 'a } +-external ref: 'a -> 'a ref = "%makemutable" +-external (!): 'a ref -> 'a = "%field0" +-external (:=): 'a ref -> 'a -> unit = "%setfield0" +-external incr: int ref -> unit = "%incr" +-external decr: int ref -> unit = "%decr" ++type 'a ref = { mutable contents : 'a } ++external ref : 'a -> 'a ref = "%makemutable" ++external ( ! ) : 'a ref -> 'a = "%field0" ++external ( := ) : 'a ref -> 'a -> unit = "%setfield0" ++external incr : int ref -> unit = "%incr" ++external decr : int ref -> unit = "%decr" + + (* Formats *) +-type ('a, 'b, 'c, 'd) format4 = ('a, 'b, 'c, 'c, 'c, 'd) format6 ++type ('a, 'b, 'c, 'd) format4 = ('a, 'b, 'c, 'c, 'c, 'd) format6 + + type ('a, 'b, 'c) format = ('a, 'b, 'c, 'c) format4 + +@@ -345,7 +428,8 @@ + ('f, 'b, 'c, 'e, 'g, 'h) format6 -> + ('a, 'b, 'c, 'd, 'g, 'h) format6) = + fun fmt1 fmt2 -> +- string_to_format (format_to_string fmt1 ^ format_to_string fmt2);; ++ string_to_format (format_to_string fmt1 ^ "%," ^ format_to_string fmt2) ++;; + + let string_of_format fmt = + let s = format_to_string fmt in +@@ -358,7 +442,7 @@ + + external sys_exit : int -> 'a = "caml_sys_exit" + +-let exit_function = ref (fun () -> ()) ++let exit_function = ref flush_all + + let at_exit f = + let g = !exit_function in --- obrowser-1.1.1.orig/rt/caml/printexc.ml 2011-04-20 18:26:44.000000000 +0200 -+++ obrowser-1.1.1/rt/caml/printexc.ml 2013-03-17 17:47:35.000000000 +0100 ++++ obrowser-1.1.1/rt/caml/printexc.ml 2013-08-13 15:54:35.000000000 +0200 @@ -1,6 +1,6 @@ (***********************************************************************) (* *) @@ -361,7 +1074,7 @@ | None -> "(Program not linked with -g, cannot print stack backtrace)\n" | Some a -> -@@ -131,6 +149,17 @@ +@@ -131,8 +149,22 @@ done; Buffer.contents b @@ -379,8 +1092,13 @@ external record_backtrace: bool -> unit = "caml_record_backtrace" external backtrace_status: unit -> bool = "caml_backtrace_status" + let register_printer fn = + printers := fn :: !printers ++ ++ ++external get_callstack: int -> raw_backtrace = "caml_get_current_callstack" --- obrowser-1.1.1.orig/rt/caml/printexc.mli 2011-04-20 18:26:44.000000000 +0200 -+++ obrowser-1.1.1/rt/caml/printexc.mli 2013-03-17 17:47:39.000000000 +0100 ++++ obrowser-1.1.1/rt/caml/printexc.mli 2013-08-13 15:54:40.000000000 +0200 @@ -1,6 +1,6 @@ (***********************************************************************) (* *) @@ -389,16 +1107,18 @@ (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) -@@ -11,8 +11,6 @@ +@@ -11,9 +11,7 @@ (* *) (***********************************************************************) -(* $Id: printexc.mli 10457 2010-05-21 18:30:12Z doligez $ *) - - (** Facilities for printing exceptions. *) +-(** Facilities for printing exceptions. *) ++(** Facilities for printing exceptions and inspecting current call stack. *) val to_string: exn -> string -@@ -77,5 +75,27 @@ + (** [Printexc.to_string e] returns a string representation of +@@ -77,5 +75,40 @@ in the reverse order of their registrations, until a printer returns a [Some s] value (if no such printer exists, the runtime will use a generic printer). @@ -426,3 +1146,16 @@ +val get_raw_backtrace: unit -> raw_backtrace +val print_raw_backtrace: out_channel -> raw_backtrace -> unit +val raw_backtrace_to_string: raw_backtrace -> string ++ ++ ++(** {6 Current call stack} *) ++ ++val get_callstack: int -> raw_backtrace ++ ++(** [Printexc.get_callstack n] returns a description of the top of the ++ call stack on the current program point (for the current thread), ++ with at most [n] entries. (Note: this function is not related to ++ exceptions at all, despite being part of the [Printexc] module.) ++ ++ @since 4.01.0 ++*) diff --git a/testsuite/external/ocamlnet-3.5.1.patch b/testsuite/external/ocamlnet-3.5.1.patch index 134311a90c..db87185412 100644 --- a/testsuite/external/ocamlnet-3.5.1.patch +++ b/testsuite/external/ocamlnet-3.5.1.patch @@ -23,3 +23,19 @@ ISO_MAPPINGS = mappings/iso*.unimap JP_MAPPINGS = mappings/jis*.*map +--- ocamlnet-3.5.1.orig/src/pop/netpop.ml 2012-02-29 19:02:53.000000000 +0100 ++++ ocamlnet-3.5.1/src/pop/netpop.ml 2013-06-20 14:06:11.000000000 +0200 +@@ -231,6 +231,7 @@ + status_response ic parse_line (Hashtbl.create 1) + with _ -> raise Protocol_error + ++(* + method stat () = + self#check_state `Transaction; + send_command oc "STAT"; +@@ -242,4 +243,5 @@ + (count, size, ext) + ) + with _ -> raise Protocol_error; ++*) + end diff --git a/testsuite/makefiles/Makefile.common b/testsuite/makefiles/Makefile.common index 5f543c6fa9..9d2716d691 100644 --- a/testsuite/makefiles/Makefile.common +++ b/testsuite/makefiles/Makefile.common @@ -22,7 +22,7 @@ CYGPATH=echo DIFF=diff -q CANKILL=true SORT=sort -SET_LD_PATH=LD_LIBRARY_PATH="$(LD_PATH)" +SET_LD_PATH=CAML_LD_LIBRARY_PATH="$(LD_PATH)" # The variables above may be overridden by .../config/Makefile # OTOPDIR is either TOPDIR or WINTOPDIR, whichever is appropriate for diff --git a/testsuite/tests/asmcomp/amd64.S b/testsuite/tests/asmcomp/amd64.S index 6ee4e294c8..846eab951b 100644 --- a/testsuite/tests/asmcomp/amd64.S +++ b/testsuite/tests/asmcomp/amd64.S @@ -18,8 +18,7 @@ #ifdef SYS_macosx #define CALL_GEN_CODE _call_gen_code - - #define CAML_C_CALL _caml_c_call +#define CAML_C_CALL _caml_c_call #define CAML_NEGF_MASK _caml_negf_mask #define CAML_ABSF_MASK _caml_absf_mask #else diff --git a/testsuite/tests/asmcomp/main.ml b/testsuite/tests/asmcomp/main.ml index 0491896984..d67a643624 100644 --- a/testsuite/tests/asmcomp/main.ml +++ b/testsuite/tests/asmcomp/main.ml @@ -19,7 +19,8 @@ let compile_file filename = let lb = Lexing.from_channel ic in try while true do - Asmgen.compile_phrase Format.std_formatter (Parsecmm.phrase Lexcmm.token lb) + Asmgen.compile_phrase Format.std_formatter + (Parsecmm.phrase Lexcmm.token lb) done with End_of_file -> diff --git a/testsuite/tests/backtrace/Makefile b/testsuite/tests/backtrace/Makefile index 9493e632fe..83f94721fb 100644 --- a/testsuite/tests/backtrace/Makefile +++ b/testsuite/tests/backtrace/Makefile @@ -13,20 +13,62 @@ BASEDIR=../.. EXECNAME=program$(EXE) -.PHONY: run-all -run-all: - @for file in *.ml; do \ +ABCDFILES=backtrace.ml +OTHERFILES=backtrace2.ml raw_backtrace.ml + +default: + $(MAKE) byte + @if $(BYTECODE_ONLY); then : ; else $(MAKE) native; fi + +.PHONY: byte +byte: + @for file in $(ABCDFILES); do \ rm -f program program.exe; \ $(OCAMLC) -g -o $(EXECNAME) $$file; \ for arg in a b c d ''; do \ - printf " ... testing '$$file' with argument '$$arg':"; \ + printf " ... testing '$$file' with ocamlc and argument '$$arg':"; \ F="`basename $$file .ml`"; \ (OCAMLRUNPARAM=b=1 $(OCAMLRUN) $(EXECNAME) $$arg || true) \ - >$$F.$$arg.result 2>&1; \ - $(DIFF) $$F.$$arg.reference $$F.$$arg.result >/dev/null \ + >$$F.$$arg.byte.result 2>&1; \ + $(DIFF) $$F.$$arg.reference $$F.$$arg.byte.result >/dev/null \ + && echo " => passed" || echo " => failed"; \ + done; \ + done + @for file in $(OTHERFILES); do \ + rm -f program program.exe; \ + $(OCAMLC) -g -o $(EXECNAME) $$file; \ + printf " ... testing '$$file' with ocamlc:"; \ + F="`basename $$file .ml`"; \ + (OCAMLRUNPARAM=b=1 $(OCAMLRUN) $(EXECNAME) $$arg || true) \ + >$$F.byte.result 2>&1; \ + $(DIFF) $$F.reference $$F.byte.result >/dev/null \ + && echo " => passed" || echo " => failed"; \ + done + +.PHONY: native +native: + @for file in $(ABCDFILES); do \ + rm -f program program.exe; \ + $(OCAMLOPT) -g -o $(EXECNAME) $$file; \ + for arg in a b c d ''; do \ + printf " ... testing '$$file' with ocamlopt and argument '$$arg':"; \ + F="`basename $$file .ml`"; \ + (OCAMLRUNPARAM=b=1 ./$(EXECNAME) $$arg || true) \ + >$$F.$$arg.native.result 2>&1; \ + $(DIFF) $$F.$$arg.reference $$F.$$arg.native.result >/dev/null \ && echo " => passed" || echo " => failed"; \ done; \ done + @for file in $(OTHERFILES); do \ + rm -f program program.exe; \ + $(OCAMLOPT) -g -o $(EXECNAME) $$file; \ + printf " ... testing '$$file' with ocamlc:"; \ + F="`basename $$file .ml`"; \ + (OCAMLRUNPARAM=b=1 ./$(EXECNAME) $$arg || true) \ + >$$F.native.result 2>&1; \ + $(DIFF) $$F.reference $$F.native.result >/dev/null \ + && echo " => passed" || echo " => failed"; \ + done .PHONY: promote promote: defaultpromote diff --git a/testsuite/tests/backtrace/backtrace2.a.reference b/testsuite/tests/backtrace/backtrace2.a.reference deleted file mode 100644 index 185c673e05..0000000000 --- a/testsuite/tests/backtrace/backtrace2.a.reference +++ /dev/null @@ -1,27 +0,0 @@ -a -No exception -b -Uncaught exception Backtrace2.Error("b") -Raised at file "backtrace2.ml", line 18, characters 21-32 -Called from file "backtrace2.ml", line 18, characters 42-53 -Called from file "backtrace2.ml", line 18, characters 42-53 -Called from file "backtrace2.ml", line 18, characters 42-53 -Called from file "backtrace2.ml", line 18, characters 42-53 -Called from file "backtrace2.ml", line 18, characters 42-53 -Called from file "backtrace2.ml", line 22, characters 4-11 -Re-raised at file "backtrace2.ml", line 24, characters 68-71 -Called from file "backtrace2.ml", line 29, characters 11-23 -Uncaught exception Backtrace2.Error("c") -Raised at file "backtrace2.ml", line 25, characters 26-37 -Called from file "backtrace2.ml", line 29, characters 11-23 -Uncaught exception Backtrace2.Error("d") -Raised at file "backtrace2.ml", line 18, characters 21-32 -Called from file "backtrace2.ml", line 18, characters 42-53 -Called from file "backtrace2.ml", line 18, characters 42-53 -Called from file "backtrace2.ml", line 18, characters 42-53 -Called from file "backtrace2.ml", line 18, characters 42-53 -Called from file "backtrace2.ml", line 18, characters 42-53 -Called from file "backtrace2.ml", line 22, characters 4-11 -Called from file "backtrace2.ml", line 29, characters 11-23 -Uncaught exception Invalid_argument("index out of bounds") -Raised by primitive operation at file "backtrace2.ml", line 29, characters 14-22 diff --git a/testsuite/tests/backtrace/backtrace2.b.reference b/testsuite/tests/backtrace/backtrace2.b.reference deleted file mode 100644 index 185c673e05..0000000000 --- a/testsuite/tests/backtrace/backtrace2.b.reference +++ /dev/null @@ -1,27 +0,0 @@ -a -No exception -b -Uncaught exception Backtrace2.Error("b") -Raised at file "backtrace2.ml", line 18, characters 21-32 -Called from file "backtrace2.ml", line 18, characters 42-53 -Called from file "backtrace2.ml", line 18, characters 42-53 -Called from file "backtrace2.ml", line 18, characters 42-53 -Called from file "backtrace2.ml", line 18, characters 42-53 -Called from file "backtrace2.ml", line 18, characters 42-53 -Called from file "backtrace2.ml", line 22, characters 4-11 -Re-raised at file "backtrace2.ml", line 24, characters 68-71 -Called from file "backtrace2.ml", line 29, characters 11-23 -Uncaught exception Backtrace2.Error("c") -Raised at file "backtrace2.ml", line 25, characters 26-37 -Called from file "backtrace2.ml", line 29, characters 11-23 -Uncaught exception Backtrace2.Error("d") -Raised at file "backtrace2.ml", line 18, characters 21-32 -Called from file "backtrace2.ml", line 18, characters 42-53 -Called from file "backtrace2.ml", line 18, characters 42-53 -Called from file "backtrace2.ml", line 18, characters 42-53 -Called from file "backtrace2.ml", line 18, characters 42-53 -Called from file "backtrace2.ml", line 18, characters 42-53 -Called from file "backtrace2.ml", line 22, characters 4-11 -Called from file "backtrace2.ml", line 29, characters 11-23 -Uncaught exception Invalid_argument("index out of bounds") -Raised by primitive operation at file "backtrace2.ml", line 29, characters 14-22 diff --git a/testsuite/tests/backtrace/backtrace2.c.reference b/testsuite/tests/backtrace/backtrace2.c.reference deleted file mode 100644 index 185c673e05..0000000000 --- a/testsuite/tests/backtrace/backtrace2.c.reference +++ /dev/null @@ -1,27 +0,0 @@ -a -No exception -b -Uncaught exception Backtrace2.Error("b") -Raised at file "backtrace2.ml", line 18, characters 21-32 -Called from file "backtrace2.ml", line 18, characters 42-53 -Called from file "backtrace2.ml", line 18, characters 42-53 -Called from file "backtrace2.ml", line 18, characters 42-53 -Called from file "backtrace2.ml", line 18, characters 42-53 -Called from file "backtrace2.ml", line 18, characters 42-53 -Called from file "backtrace2.ml", line 22, characters 4-11 -Re-raised at file "backtrace2.ml", line 24, characters 68-71 -Called from file "backtrace2.ml", line 29, characters 11-23 -Uncaught exception Backtrace2.Error("c") -Raised at file "backtrace2.ml", line 25, characters 26-37 -Called from file "backtrace2.ml", line 29, characters 11-23 -Uncaught exception Backtrace2.Error("d") -Raised at file "backtrace2.ml", line 18, characters 21-32 -Called from file "backtrace2.ml", line 18, characters 42-53 -Called from file "backtrace2.ml", line 18, characters 42-53 -Called from file "backtrace2.ml", line 18, characters 42-53 -Called from file "backtrace2.ml", line 18, characters 42-53 -Called from file "backtrace2.ml", line 18, characters 42-53 -Called from file "backtrace2.ml", line 22, characters 4-11 -Called from file "backtrace2.ml", line 29, characters 11-23 -Uncaught exception Invalid_argument("index out of bounds") -Raised by primitive operation at file "backtrace2.ml", line 29, characters 14-22 diff --git a/testsuite/tests/backtrace/backtrace2.d.reference b/testsuite/tests/backtrace/backtrace2.d.reference deleted file mode 100644 index 185c673e05..0000000000 --- a/testsuite/tests/backtrace/backtrace2.d.reference +++ /dev/null @@ -1,27 +0,0 @@ -a -No exception -b -Uncaught exception Backtrace2.Error("b") -Raised at file "backtrace2.ml", line 18, characters 21-32 -Called from file "backtrace2.ml", line 18, characters 42-53 -Called from file "backtrace2.ml", line 18, characters 42-53 -Called from file "backtrace2.ml", line 18, characters 42-53 -Called from file "backtrace2.ml", line 18, characters 42-53 -Called from file "backtrace2.ml", line 18, characters 42-53 -Called from file "backtrace2.ml", line 22, characters 4-11 -Re-raised at file "backtrace2.ml", line 24, characters 68-71 -Called from file "backtrace2.ml", line 29, characters 11-23 -Uncaught exception Backtrace2.Error("c") -Raised at file "backtrace2.ml", line 25, characters 26-37 -Called from file "backtrace2.ml", line 29, characters 11-23 -Uncaught exception Backtrace2.Error("d") -Raised at file "backtrace2.ml", line 18, characters 21-32 -Called from file "backtrace2.ml", line 18, characters 42-53 -Called from file "backtrace2.ml", line 18, characters 42-53 -Called from file "backtrace2.ml", line 18, characters 42-53 -Called from file "backtrace2.ml", line 18, characters 42-53 -Called from file "backtrace2.ml", line 18, characters 42-53 -Called from file "backtrace2.ml", line 22, characters 4-11 -Called from file "backtrace2.ml", line 29, characters 11-23 -Uncaught exception Invalid_argument("index out of bounds") -Raised by primitive operation at file "backtrace2.ml", line 29, characters 14-22 diff --git a/testsuite/tests/backtrace/backtrace2..reference b/testsuite/tests/backtrace/backtrace2.reference index 185c673e05..185c673e05 100644 --- a/testsuite/tests/backtrace/backtrace2..reference +++ b/testsuite/tests/backtrace/backtrace2.reference diff --git a/testsuite/tests/backtrace/raw_backtrace.ml b/testsuite/tests/backtrace/raw_backtrace.ml new file mode 100644 index 0000000000..f271f759d5 --- /dev/null +++ b/testsuite/tests/backtrace/raw_backtrace.ml @@ -0,0 +1,52 @@ +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2008 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. *) +(* *) +(***********************************************************************) + +(* A test for stack backtraces *) + +exception Error of string + +let rec f msg n = + if n = 0 then raise(Error msg) else 1 + f msg (n-1) + +let g msg = + try + f msg 5 + with Error "a" -> print_string "a"; print_newline(); 0 + | Error "b" as exn -> print_string "b"; print_newline(); raise exn + | Error "c" -> raise (Error "c") + +let backtrace args = + try + ignore (g args.(0)); None + with exn -> + let exn = Printexc.to_string exn in + let trace = Printexc.get_raw_backtrace () in + Some (exn, trace) + +let run args = + match backtrace args with + | None -> print_string "No exception\n" + | Some (exn, trace) -> + begin + (* raise another exception to stash the global backtrace *) + try ignore (f "c" 5); assert false with Error _ -> (); + end; + Printf.printf "Uncaught exception %s\n" exn; + Printexc.print_raw_backtrace stdout trace + +let _ = + Printexc.record_backtrace true; + run [| "a" |]; + run [| "b" |]; + run [| "c" |]; + run [| "d" |]; + run [| |] diff --git a/testsuite/tests/backtrace/raw_backtrace.reference b/testsuite/tests/backtrace/raw_backtrace.reference new file mode 100644 index 0000000000..96fb60e8c2 --- /dev/null +++ b/testsuite/tests/backtrace/raw_backtrace.reference @@ -0,0 +1,27 @@ +a +No exception +b +Uncaught exception Raw_backtrace.Error("b") +Raised at file "raw_backtrace.ml", line 18, characters 21-32 +Called from file "raw_backtrace.ml", line 18, characters 42-53 +Called from file "raw_backtrace.ml", line 18, characters 42-53 +Called from file "raw_backtrace.ml", line 18, characters 42-53 +Called from file "raw_backtrace.ml", line 18, characters 42-53 +Called from file "raw_backtrace.ml", line 18, characters 42-53 +Called from file "raw_backtrace.ml", line 22, characters 4-11 +Re-raised at file "raw_backtrace.ml", line 24, characters 68-71 +Called from file "raw_backtrace.ml", line 29, characters 11-23 +Uncaught exception Raw_backtrace.Error("c") +Raised at file "raw_backtrace.ml", line 25, characters 26-37 +Called from file "raw_backtrace.ml", line 29, characters 11-23 +Uncaught exception Raw_backtrace.Error("d") +Raised at file "raw_backtrace.ml", line 18, characters 21-32 +Called from file "raw_backtrace.ml", line 18, characters 42-53 +Called from file "raw_backtrace.ml", line 18, characters 42-53 +Called from file "raw_backtrace.ml", line 18, characters 42-53 +Called from file "raw_backtrace.ml", line 18, characters 42-53 +Called from file "raw_backtrace.ml", line 18, characters 42-53 +Called from file "raw_backtrace.ml", line 22, characters 4-11 +Called from file "raw_backtrace.ml", line 29, characters 11-23 +Uncaught exception Invalid_argument("index out of bounds") +Raised by primitive operation at file "raw_backtrace.ml", line 29, characters 14-22 diff --git a/testsuite/tests/basic-io-2/test-file-short-lines b/testsuite/tests/basic-io-2/test-file-short-lines index 35abe7ca2e..9c0f7b97e8 100644 --- a/testsuite/tests/basic-io-2/test-file-short-lines +++ b/testsuite/tests/basic-io-2/test-file-short-lines @@ -6,5 +6,5 @@ ## 127.0.0.1 localhost 255.255.255.255 broadcasthost -::1 localhost +::1 localhost fe80::1%lo0 localhost diff --git a/testsuite/tests/basic-manyargs/manyargs.ml b/testsuite/tests/basic-manyargs/manyargs.ml index d2e8663d20..3defdf201f 100644 --- a/testsuite/tests/basic-manyargs/manyargs.ml +++ b/testsuite/tests/basic-manyargs/manyargs.ml @@ -47,7 +47,10 @@ let _ = manyargs_tail2 0 1; manyargs_tail3 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 -external manyargs_ext: int -> int -> int -> int -> int -> int -> int -> int -> int -> int -> int -> int = "manyargs_argv" "manyargs" +external manyargs_ext: + int -> int -> int -> int -> int -> int -> int -> int -> int -> int -> int -> + int + = "manyargs_argv" "manyargs" let _ = print_string "external:\n"; flush stdout; diff --git a/testsuite/tests/basic/arrays.ml b/testsuite/tests/basic/arrays.ml index e496c48578..e123edff61 100644 --- a/testsuite/tests/basic/arrays.ml +++ b/testsuite/tests/basic/arrays.ml @@ -102,7 +102,8 @@ let test4 () = let test5 () = if Array.append [| 1;2;3 |] [| 4;5 |] <> [| 1;2;3;4;5 |] then print_string "Test5: failed on int arrays\n"; - if Array.append [| 1.0;2.0;3.0 |] [| 4.0;5.0 |] <> [| 1.0;2.0;3.0;4.0;5.0 |] then + if Array.append [| 1.0;2.0;3.0 |] [| 4.0;5.0 |] <> [| 1.0;2.0;3.0;4.0;5.0 |] + then print_string "Test5: failed on float arrays\n" let test6 () = diff --git a/testsuite/tests/basic/boxedints.ml b/testsuite/tests/basic/boxedints.ml index c127e4f971..bcb0b8230f 100644 --- a/testsuite/tests/basic/boxedints.ml +++ b/testsuite/tests/basic/boxedints.ml @@ -565,7 +565,7 @@ let _ = test 3 (Nativeint.to_int32 (Nativeint.of_string "0x123456789ABCDEF0")) (Int32.of_string "0x9ABCDEF0") else - test 3 0 0; (* placeholder to have the same output on both 32-bit and 64-bit *) + test 3 0 0; (* placeholder to have the same output on 32-bit and 64-bit *) testing_function "int64 of/to int32"; test 1 (Int64.of_int32 (Int32.of_string "-0x12345678")) (Int64.of_string "-0x12345678"); diff --git a/testsuite/tests/basic/patmatch.ml b/testsuite/tests/basic/patmatch.ml index fbb0870a1c..8f522a9c39 100644 --- a/testsuite/tests/basic/patmatch.ml +++ b/testsuite/tests/basic/patmatch.ml @@ -119,7 +119,7 @@ let _ = (* Was segfaulting *) let f = function - | lazy (), _, {contents=None} -> 0 + | lazy (), _, {contents=None} -> 0 | _, lazy (), {contents=Some x} -> 1 let s = ref None @@ -129,5 +129,3 @@ let set_false = lazy (s := None) let () = let _r = try f (set_true, set_false, s) with Match_failure _ -> 2 in printf "PR#5992=Ok\n" - - diff --git a/testsuite/tests/callback/tcallback.ml b/testsuite/tests/callback/tcallback.ml index 28de42802c..69cae5c2fc 100644 --- a/testsuite/tests/callback/tcallback.ml +++ b/testsuite/tests/callback/tcallback.ml @@ -12,8 +12,10 @@ external mycallback1 : ('a -> 'b) -> 'a -> 'b = "mycallback1" external mycallback2 : ('a -> 'b -> 'c) -> 'a -> 'b -> 'c = "mycallback2" -external mycallback3 : ('a -> 'b -> 'c -> 'd) -> 'a -> 'b -> 'c -> 'd = "mycallback3" -external mycallback4 : ('a -> 'b -> 'c -> 'd -> 'e) -> 'a -> 'b -> 'c -> 'd -> 'e = "mycallback4" +external mycallback3 : ('a -> 'b -> 'c -> 'd) -> 'a -> 'b -> 'c -> 'd + = "mycallback3" +external mycallback4 : + ('a -> 'b -> 'c -> 'd -> 'e) -> 'a -> 'b -> 'c -> 'd -> 'e = "mycallback4" let rec tak (x, y, z as _tuple) = if x > y then tak(tak (x-1, y, z), tak (y-1, z, x), tak (z-1, x, y)) diff --git a/testsuite/tests/lib-threads/test4.ml b/testsuite/tests/lib-threads/test4.ml index 90692c9a08..7fb789c761 100644 --- a/testsuite/tests/lib-threads/test4.ml +++ b/testsuite/tests/lib-threads/test4.ml @@ -16,8 +16,9 @@ let rec fib n = if n <= 2 then 1 else fib(n-1) + fib(n-2) let fibtask n = while true do + let res = fib n in Mutex.lock output_lock; - print_int(fib n); print_newline(); + print_int res; print_newline(); Mutex.unlock output_lock done diff --git a/testsuite/tests/lib-threads/test8.precheck b/testsuite/tests/lib-threads/test8.precheck new file mode 100644 index 0000000000..aa357092af --- /dev/null +++ b/testsuite/tests/lib-threads/test8.precheck @@ -0,0 +1,13 @@ +######################################################################### +# # +# OCaml # +# # +# Damien Doligez, projet 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. # +# # +######################################################################### + +$CANKILL diff --git a/testsuite/tests/lib-threads/test9.precheck b/testsuite/tests/lib-threads/test9.precheck new file mode 100644 index 0000000000..aa357092af --- /dev/null +++ b/testsuite/tests/lib-threads/test9.precheck @@ -0,0 +1,13 @@ +######################################################################### +# # +# OCaml # +# # +# Damien Doligez, projet 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. # +# # +######################################################################### + +$CANKILL diff --git a/testsuite/tests/typing-gadts/pr5985.ml b/testsuite/tests/typing-gadts/pr5985.ml index 4bffe1224e..fdc66e8238 100644 --- a/testsuite/tests/typing-gadts/pr5985.ml +++ b/testsuite/tests/typing-gadts/pr5985.ml @@ -87,3 +87,8 @@ class virtual ['a] item_container = constraint 'a = < as_item : [>`widget] obj; .. > method virtual add : 'a -> unit end;; + + +(* Another variance anomaly, should not expand t in g before checking *) +type +'a t = unit constraint 'a = 'b list;; +type _ g = G : 'a -> 'a t g;; (* fail *) diff --git a/testsuite/tests/typing-gadts/pr5985.ml.reference b/testsuite/tests/typing-gadts/pr5985.ml.reference index fd0b560e50..fc7d792a88 100644 --- a/testsuite/tests/typing-gadts/pr5985.ml.reference +++ b/testsuite/tests/typing-gadts/pr5985.ml.reference @@ -66,4 +66,10 @@ Error: In this definition, a type variable has a variance that constraint 'a = < as_item : [> `widget ] Gobject.obj; .. > method virtual add : 'a -> unit end +# type +'a t = unit constraint 'a = 'b list +# Characters 4-27: + type _ g = G : 'a -> 'a t g;; (* fail *) + ^^^^^^^^^^^^^^^^^^^^^^^ +Error: In this definition, a type variable cannot be deduced + from the type parameters. # diff --git a/testsuite/tests/typing-gadts/pr6158.ml b/testsuite/tests/typing-gadts/pr6158.ml new file mode 100644 index 0000000000..752380cb37 --- /dev/null +++ b/testsuite/tests/typing-gadts/pr6158.ml @@ -0,0 +1,9 @@ +type 'a t = T of 'a +type 'a s = S of 'a + +type (_, _) eq = Refl : ('a, 'a) eq;; + +let f : (int s, int t) eq -> unit = function Refl -> ();; + +module M (S : sig type 'a t = T of 'a type 'a s = T of 'a end) = +struct let f : ('a S.s, 'a S.t) eq -> unit = function Refl -> () end;; diff --git a/testsuite/tests/typing-gadts/pr6158.ml.principal.reference b/testsuite/tests/typing-gadts/pr6158.ml.principal.reference new file mode 100644 index 0000000000..e7d5458744 --- /dev/null +++ b/testsuite/tests/typing-gadts/pr6158.ml.principal.reference @@ -0,0 +1,19 @@ + +# type 'a t = T of 'a +type 'a s = S of 'a +type (_, _) eq = Refl : ('a, 'a) eq +# Characters 46-50: + let f : (int s, int t) eq -> unit = function Refl -> ();; + ^^^^ +Error: This pattern matches values of type (int s, int s) eq + but a pattern was expected which matches values of type + (int s, int t) eq + Type int s is not compatible with type int t +# Characters 120-124: + struct let f : ('a S.s, 'a S.t) eq -> unit = function Refl -> () end;; + ^^^^ +Error: This pattern matches values of type (ex#0 S.s, ex#1 S.t) eq + but a pattern was expected which matches values of type + (ex#0 S.s, ex#0 S.t) eq + The type constructor ex#0 would escape its scope +# diff --git a/testsuite/tests/typing-gadts/pr6158.ml.reference b/testsuite/tests/typing-gadts/pr6158.ml.reference new file mode 100644 index 0000000000..c7d5c1eca8 --- /dev/null +++ b/testsuite/tests/typing-gadts/pr6158.ml.reference @@ -0,0 +1,15 @@ + +# type 'a t = T of 'a +type 'a s = S of 'a +type (_, _) eq = Refl : ('a, 'a) eq +# Characters 46-50: + let f : (int s, int t) eq -> unit = function Refl -> ();; + ^^^^ +Error: This pattern matches values of type (int s, int s) eq + but a pattern was expected which matches values of type + (int s, int t) eq + Type int s is not compatible with type int t +# module M : + functor (S : sig type 'a t = T of 'a type 'a s = T of 'a end) -> + sig val f : (a#0 S.s, a#0 S.t) eq -> unit end +# diff --git a/testsuite/tests/typing-gadts/pr6163.ml b/testsuite/tests/typing-gadts/pr6163.ml new file mode 100644 index 0000000000..e9646196e7 --- /dev/null +++ b/testsuite/tests/typing-gadts/pr6163.ml @@ -0,0 +1,14 @@ +type _ nat = + Zero : [`Zero] nat + | Succ : 'a nat -> [`Succ of 'a] nat;; +type 'a pre_nat = [`Zero | `Succ of 'a];; +type aux = + | Aux : [`Succ of [<[<[<[`Zero] pre_nat] pre_nat] pre_nat]] nat -> aux;; + +let f (Aux x) = + match x with + | Succ Zero -> "1" + | Succ (Succ Zero) -> "2" + | Succ (Succ (Succ Zero)) -> "3" + | Succ (Succ (Succ (Succ Zero))) -> "4" +;; diff --git a/testsuite/tests/typing-gadts/pr6163.ml.principal.reference b/testsuite/tests/typing-gadts/pr6163.ml.principal.reference new file mode 100644 index 0000000000..0b771dc76f --- /dev/null +++ b/testsuite/tests/typing-gadts/pr6163.ml.principal.reference @@ -0,0 +1,18 @@ + +# type _ nat = Zero : [ `Zero ] nat | Succ : 'a nat -> [ `Succ of 'a ] nat +# type 'a pre_nat = [ `Succ of 'a | `Zero ] +# type aux = + Aux : + [ `Succ of [< [< [< [ `Zero ] pre_nat ] pre_nat ] pre_nat ] ] nat -> + aux +# Characters 19-157: + ..match x with + | Succ Zero -> "1" + | Succ (Succ Zero) -> "2" + | Succ (Succ (Succ Zero)) -> "3" + | Succ (Succ (Succ (Succ Zero))) -> "4" +Warning 8: this pattern-matching is not exhaustive. +Here is an example of a value that is not matched: +Succ (Succ (Succ (Succ (Succ _)))) +val f : aux -> string = <fun> +# diff --git a/testsuite/tests/typing-gadts/pr6163.ml.reference b/testsuite/tests/typing-gadts/pr6163.ml.reference new file mode 100644 index 0000000000..0b771dc76f --- /dev/null +++ b/testsuite/tests/typing-gadts/pr6163.ml.reference @@ -0,0 +1,18 @@ + +# type _ nat = Zero : [ `Zero ] nat | Succ : 'a nat -> [ `Succ of 'a ] nat +# type 'a pre_nat = [ `Succ of 'a | `Zero ] +# type aux = + Aux : + [ `Succ of [< [< [< [ `Zero ] pre_nat ] pre_nat ] pre_nat ] ] nat -> + aux +# Characters 19-157: + ..match x with + | Succ Zero -> "1" + | Succ (Succ Zero) -> "2" + | Succ (Succ (Succ Zero)) -> "3" + | Succ (Succ (Succ (Succ Zero))) -> "4" +Warning 8: this pattern-matching is not exhaustive. +Here is an example of a value that is not matched: +Succ (Succ (Succ (Succ (Succ _)))) +val f : aux -> string = <fun> +# diff --git a/testsuite/tests/typing-gadts/test.ml b/testsuite/tests/typing-gadts/test.ml index dc219f4219..a8215290ad 100644 --- a/testsuite/tests/typing-gadts/test.ml +++ b/testsuite/tests/typing-gadts/test.ml @@ -518,3 +518,22 @@ let g : type a. a ty -> a = module M = struct type _ t = int end;; module M = struct type _ t = T : int t end;; module N = M;; + +(* Principality *) + +(* adding a useless equation should not break inference *) +let f : type a b. (a,b) eq -> (a,int) eq -> a -> b -> _ = fun ab aint a b -> + let Eq = ab in + let x = + let Eq = aint in + if true then a else b + in ignore x +;; (* ok *) + +let f : type a b. (a,b) eq -> (b,int) eq -> a -> b -> _ = fun ab bint a b -> + let Eq = ab in + let x = + let Eq = bint in + if true then a else b + in ignore x +;; (* ok *) diff --git a/testsuite/tests/typing-gadts/test.ml.principal.reference b/testsuite/tests/typing-gadts/test.ml.principal.reference index 21f8526d28..551f9cb2d9 100644 --- a/testsuite/tests/typing-gadts/test.ml.principal.reference +++ b/testsuite/tests/typing-gadts/test.ml.principal.reference @@ -312,4 +312,6 @@ Error: This expression has type < bar : int; foo : int; .. > as 'a # module M : sig type _ t = int end # module M : sig type _ t = T : int t end # module N : sig type 'a t = 'a M.t = T : int t end +# val f : ('a, 'b) eq -> ('a, int) eq -> 'a -> 'b -> unit = <fun> +# val f : ('a, 'b) eq -> ('b, int) eq -> 'a -> 'b -> unit = <fun> # diff --git a/testsuite/tests/typing-gadts/test.ml.reference b/testsuite/tests/typing-gadts/test.ml.reference index 3b84f92401..fc62f5d573 100644 --- a/testsuite/tests/typing-gadts/test.ml.reference +++ b/testsuite/tests/typing-gadts/test.ml.reference @@ -298,4 +298,6 @@ Error: This expression has type < bar : int; foo : int; .. > as 'a # module M : sig type _ t = int end # module M : sig type _ t = T : int t end # module N : sig type 'a t = 'a M.t = T : int t end +# val f : ('a, 'b) eq -> ('a, int) eq -> 'a -> 'b -> unit = <fun> +# val f : ('a, 'b) eq -> ('b, int) eq -> 'a -> 'b -> unit = <fun> # diff --git a/testsuite/tests/typing-modules-bugs/pr5914_ok.ml b/testsuite/tests/typing-modules-bugs/pr5914_ok.ml new file mode 100644 index 0000000000..fb21cd4b4a --- /dev/null +++ b/testsuite/tests/typing-modules-bugs/pr5914_ok.ml @@ -0,0 +1,18 @@ +type 't a = [ `A ] +type 't wrap = 't constraint 't = [> 't wrap a ] +type t = t a wrap + +module T = struct + let foo : 't wrap -> 't wrap -> unit = fun _ _ -> () + let bar : ('a a wrap as 'a) = `A +end + +module Good : sig + val bar: t + val foo: t -> t -> unit +end = T + +module Bad : sig + val foo: t -> t -> unit + val bar: t +end = T diff --git a/testsuite/tests/typing-modules/Test.ml b/testsuite/tests/typing-modules/Test.ml index bcdfa81ac3..e5cbe9f395 100644 --- a/testsuite/tests/typing-modules/Test.ml +++ b/testsuite/tests/typing-modules/Test.ml @@ -50,3 +50,7 @@ module M : sig type -'a t = private int end = module type A = sig type t = X of int end;; type u = X of bool;; module type B = A with type t = u;; (* fail *) + +(* PR#5815 *) + +module type S = sig exception Foo of int exception Foo of bool end;; diff --git a/testsuite/tests/typing-modules/Test.ml.principal.reference b/testsuite/tests/typing-modules/Test.ml.principal.reference index eebe307ed8..8e993fa3aa 100644 --- a/testsuite/tests/typing-modules/Test.ml.principal.reference +++ b/testsuite/tests/typing-modules/Test.ml.principal.reference @@ -28,4 +28,5 @@ Error: Signature mismatch: ^^^^^^^^^^ Error: This variant or record definition does not match that of type u The types for field X are not equal. +# module type S = sig exception Foo of bool end # diff --git a/testsuite/tests/typing-modules/Test.ml.reference b/testsuite/tests/typing-modules/Test.ml.reference index eebe307ed8..8e993fa3aa 100644 --- a/testsuite/tests/typing-modules/Test.ml.reference +++ b/testsuite/tests/typing-modules/Test.ml.reference @@ -28,4 +28,5 @@ Error: Signature mismatch: ^^^^^^^^^^ Error: This variant or record definition does not match that of type u The types for field X are not equal. +# module type S = sig exception Foo of bool end # diff --git a/testsuite/tests/typing-objects/pr6123_bad.ml b/testsuite/tests/typing-objects/pr6123_bad.ml new file mode 100644 index 0000000000..a773f8d70e --- /dev/null +++ b/testsuite/tests/typing-objects/pr6123_bad.ml @@ -0,0 +1,23 @@ +class virtual name = +object +end + +and func (args_ty, ret_ty) = +object(self) + inherit name + + val mutable memo_args = None + + method arguments = + match memo_args with + | Some xs -> xs + | None -> + let args = List.map (fun ty -> new argument(self, ty)) args_ty in + memo_args <- Some args; args +end + +and argument (func, ty) = +object + inherit name +end +;; diff --git a/testsuite/tests/typing-objects/pr6123_bad.ml.principal.reference b/testsuite/tests/typing-objects/pr6123_bad.ml.principal.reference new file mode 100644 index 0000000000..a7e48182e3 --- /dev/null +++ b/testsuite/tests/typing-objects/pr6123_bad.ml.principal.reference @@ -0,0 +1,8 @@ + +# Characters 253-257: + let args = List.map (fun ty -> new argument(self, ty)) args_ty in + ^^^^ +Error: This expression has type < arguments : 'b; .. > as 'a + but an expression was expected of type 'a + Self type cannot escape its class +# diff --git a/testsuite/tests/typing-objects/pr6123_bad.ml.reference b/testsuite/tests/typing-objects/pr6123_bad.ml.reference new file mode 100644 index 0000000000..a7e48182e3 --- /dev/null +++ b/testsuite/tests/typing-objects/pr6123_bad.ml.reference @@ -0,0 +1,8 @@ + +# Characters 253-257: + let args = List.map (fun ty -> new argument(self, ty)) args_ty in + ^^^^ +Error: This expression has type < arguments : 'b; .. > as 'a + but an expression was expected of type 'a + Self type cannot escape its class +# diff --git a/testsuite/tests/typing-poly/poly.ml b/testsuite/tests/typing-poly/poly.ml index a353e19a55..36dc76a43a 100644 --- a/testsuite/tests/typing-poly/poly.ml +++ b/testsuite/tests/typing-poly/poly.ml @@ -654,3 +654,16 @@ let (A x) = (raise Exit : s);; (* PR#5224 *) type 'x t = < f : 'y. 'y t >;; + +(* PR#6056, PR#6057 *) +let using_match b = + let f = + match b with + | true -> fun x -> x + | false -> fun x -> x + in + f 0,f +;; + +match (fun x -> x), fun x -> x with x, y -> x, y;; +match fun x -> x with x -> x, x;; diff --git a/testsuite/tests/typing-poly/poly.ml.principal.reference b/testsuite/tests/typing-poly/poly.ml.principal.reference index 0f71484af5..53acb415ba 100644 --- a/testsuite/tests/typing-poly/poly.ml.principal.reference +++ b/testsuite/tests/typing-poly/poly.ml.principal.reference @@ -644,4 +644,7 @@ Error: This field value has type unit -> unit which is less general than type 'x t = < f : 'y. 'y t >;; ^^^^^^^^^^^^^^^^^^^^^^^^ Error: In the definition of t, type 'y t should be 'x t +# val using_match : bool -> int * ('a -> 'a) = <fun> +# - : ('a -> 'a) * ('b -> 'b) = (<fun>, <fun>) +# - : ('a -> 'a) * ('b -> 'b) = (<fun>, <fun>) # diff --git a/testsuite/tests/typing-poly/poly.ml.reference b/testsuite/tests/typing-poly/poly.ml.reference index 311c5427b4..9929020d54 100644 --- a/testsuite/tests/typing-poly/poly.ml.reference +++ b/testsuite/tests/typing-poly/poly.ml.reference @@ -602,4 +602,7 @@ Error: This field value has type unit -> unit which is less general than type 'x t = < f : 'y. 'y t >;; ^^^^^^^^^^^^^^^^^^^^^^^^ Error: In the definition of t, type 'y t should be 'x t +# val using_match : bool -> int * ('a -> 'a) = <fun> +# - : ('a -> 'a) * ('b -> 'b) = (<fun>, <fun>) +# - : ('a -> 'a) * ('b -> 'b) = (<fun>, <fun>) # diff --git a/testsuite/tests/typing-private/private.ml b/testsuite/tests/typing-private/private.ml index 5969e18b96..2ad0018398 100644 --- a/testsuite/tests/typing-private/private.ml +++ b/testsuite/tests/typing-private/private.ml @@ -93,3 +93,13 @@ module M : sig type 'a t = private T of 'a end = module M1 : sig type 'a t = 'a M.t = private T of 'a end = struct type 'a t = 'a M.t = private T of 'a end;; + +(* PR#6090 *) +module Test = struct type t = private A end +module Test2 : module type of Test with type t = Test.t = Test;; +let f (x : Test.t) = (x : Test2.t);; +let f Test2.A = ();; +let a = Test2.A;; (* fail *) +(* The following should fail from a semantical point of view, + but allow it for backward compatibility *) +module Test2 : module type of Test with type t = private Test.t = Test;; diff --git a/testsuite/tests/typing-private/private.ml.reference b/testsuite/tests/typing-private/private.ml.reference index a231a07ab6..c9f0b5a0e9 100644 --- a/testsuite/tests/typing-private/private.ml.reference +++ b/testsuite/tests/typing-private/private.ml.reference @@ -96,4 +96,13 @@ Error: This variant or record definition does not match that of type M.t # module M3' : sig type t = M'.t val mk : int -> t end # module M : sig type 'a t = private T of 'a end # module M1 : sig type 'a t = 'a M.t = private T of 'a end +# module Test : sig type t = private A end +module Test2 : sig type t = Test.t = private A end +# val f : Test.t -> Test2.t = <fun> +# val f : Test2.t -> unit = <fun> +# Characters 8-15: + let a = Test2.A;; (* fail *) + ^^^^^^^ +Error: Cannot create values of the private type Test2.t +# * module Test2 : sig type t = Test.t = private A end # diff --git a/testsuite/tests/typing-warnings/records.ml b/testsuite/tests/typing-warnings/records.ml index 61a33c863b..61a21cebb6 100644 --- a/testsuite/tests/typing-warnings/records.ml +++ b/testsuite/tests/typing-warnings/records.ml @@ -138,3 +138,23 @@ class g = f A;; (* ok *) class f (_ : 'a) (_ : 'a) = object end;; class g = f (A : t) A;; (* warn with -principal *) + + +(* PR#5980 *) + +module Shadow1 = struct + type t = {x: int} + module M = struct + type s = {x: string} + end + open M (* this open is unused, it isn't reported as shadowing 'x' *) + let y : t = {x = 0} +end;; +module Shadow2 = struct + type t = {x: int} + module M = struct + type s = {x: string} + end + open M (* this open shadows label 'x' *) + let y = {x = ""} +end;; diff --git a/testsuite/tests/typing-warnings/records.ml.principal.reference b/testsuite/tests/typing-warnings/records.ml.principal.reference index 7a7745a905..7c66a0ab04 100644 --- a/testsuite/tests/typing-warnings/records.ml.principal.reference +++ b/testsuite/tests/typing-warnings/records.ml.principal.reference @@ -247,4 +247,33 @@ Characters 20-21: ^ Warning 42: this use of A required disambiguation. class g : f +# Characters 199-200: + let y : t = {x = 0} + ^ +Warning 42: this use of x required disambiguation. +Characters 114-120: + open M (* this open is unused, it isn't reported as shadowing 'x' *) + ^^^^^^ +Warning 33: unused open M. +module Shadow1 : + sig + type t = { x : int; } + module M : sig type s = { x : string; } end + val y : t + end +# Characters 97-103: + open M (* this open shadows label 'x' *) + ^^^^^^ +Warning 45: this open statement shadows the label x (which is later used) +Characters 149-157: + let y = {x = ""} + ^^^^^^^^ +Warning 41: these field labels belong to several types: M.s t +The first one was selected. Please disambiguate if this is wrong. +module Shadow2 : + sig + type t = { x : int; } + module M : sig type s = { x : string; } end + val y : M.s + end # diff --git a/testsuite/tests/typing-warnings/records.ml.reference b/testsuite/tests/typing-warnings/records.ml.reference index c88439c648..2952abd6b0 100644 --- a/testsuite/tests/typing-warnings/records.ml.reference +++ b/testsuite/tests/typing-warnings/records.ml.reference @@ -246,4 +246,33 @@ Characters 20-21: ^ Warning 42: this use of A required disambiguation. class g : f +# Characters 199-200: + let y : t = {x = 0} + ^ +Warning 42: this use of x required disambiguation. +Characters 114-120: + open M (* this open is unused, it isn't reported as shadowing 'x' *) + ^^^^^^ +Warning 33: unused open M. +module Shadow1 : + sig + type t = { x : int; } + module M : sig type s = { x : string; } end + val y : t + end +# Characters 97-103: + open M (* this open shadows label 'x' *) + ^^^^^^ +Warning 45: this open statement shadows the label x (which is later used) +Characters 149-157: + let y = {x = ""} + ^^^^^^^^ +Warning 41: these field labels belong to several types: M.s t +The first one was selected. Please disambiguate if this is wrong. +module Shadow2 : + sig + type t = { x : int; } + module M : sig type s = { x : string; } end + val y : M.s + end # diff --git a/testsuite/tests/utils/Makefile b/testsuite/tests/utils/Makefile index 9be8d6a8d1..4b7ab0dd42 100644 --- a/testsuite/tests/utils/Makefile +++ b/testsuite/tests/utils/Makefile @@ -1,3 +1,15 @@ +######################################################################### +# # +# OCaml # +# # +# Alain Frisch, LexiFi # +# # +# Copyright 2012 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=testing misc INCLUDES= -I $(OTOPDIR)/utils diff --git a/testsuite/tests/warnings/w01.ml b/testsuite/tests/warnings/w01.ml index 08e2f29108..24a6accc9e 100644 --- a/testsuite/tests/warnings/w01.ml +++ b/testsuite/tests/warnings/w01.ml @@ -1,3 +1,14 @@ +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Damien Doligez, projet Moscova, INRIA Rocquencourt *) +(* *) +(* Copyright 2000 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. *) +(* *) +(***********************************************************************) (* C *) diff --git a/testsuite/tests/warnings/w01.reference b/testsuite/tests/warnings/w01.reference index 492ec7dc52..730da03c9a 100644 --- a/testsuite/tests/warnings/w01.reference +++ b/testsuite/tests/warnings/w01.reference @@ -1,15 +1,15 @@ -File "w01.ml", line 4, characters 12-14: +File "w01.ml", line 15, characters 12-14: Warning 2: this is not the end of a comment. -File "w01.ml", line 10, characters 0-3: +File "w01.ml", line 21, characters 0-3: Warning 5: this function application is partial, maybe some arguments are missing. -File "w01.ml", line 20, characters 4-5: +File "w01.ml", line 31, characters 4-5: Warning 8: this pattern-matching is not exhaustive. Here is an example of a value that is not matched: 0 -File "w01.ml", line 25, characters 0-1: +File "w01.ml", line 36, characters 0-1: Warning 10: this expression should have type unit. -File "w01.ml", line 9, characters 8-9: +File "w01.ml", line 20, characters 8-9: Warning 27: unused variable y. -File "w01.ml", line 32, characters 2-3: +File "w01.ml", line 43, characters 2-3: Warning 11: this match case is unused. diff --git a/testsuite/typing b/testsuite/typing new file mode 100644 index 0000000000..b2e68dc5cf --- /dev/null +++ b/testsuite/typing @@ -0,0 +1,22 @@ +tests/typing-fstclassmod +tests/typing-gadts +tests/typing-implicit_unpack +tests/typing-labels +tests/typing-misc +tests/typing-modules +tests/typing-modules-bugs +tests/typing-objects +tests/typing-objects-bugs +tests/typing-poly +tests/typing-poly-bugs +tests/typing-polyvariants-bugs +tests/typing-polyvariants-bugs-2 +tests/typing-private +tests/typing-private-bugs +tests/typing-recmod +tests/typing-rectypes-bugs +tests/typing-short-paths +tests/typing-signatures +tests/typing-sigsubst +tests/typing-typeparam +tests/typing-warnings diff --git a/tools/.depend b/tools/.depend index 0a68fd85cb..6719b5d51f 100644 --- a/tools/.depend +++ b/tools/.depend @@ -78,10 +78,6 @@ ocamlprof.cmx : ../utils/warnings.cmx ../parsing/syntaxerr.cmx \ ../parsing/lexer.cmx opnames.cmo : opnames.cmx : -pprintast.cmo : ../parsing/parsetree.cmi ../utils/misc.cmi \ - ../parsing/longident.cmi ../parsing/location.cmi ../parsing/asttypes.cmi -pprintast.cmx : ../parsing/parsetree.cmi ../utils/misc.cmx \ - ../parsing/longident.cmx ../parsing/location.cmx ../parsing/asttypes.cmi primreq.cmo : ../utils/config.cmi ../bytecomp/cmo_format.cmi primreq.cmx : ../utils/config.cmx ../bytecomp/cmo_format.cmi profiling.cmo : profiling.cmi diff --git a/tools/addlabels.ml b/tools/addlabels.ml index 6daab8b794..cc94f5eabc 100644 --- a/tools/addlabels.ml +++ b/tools/addlabels.ml @@ -190,7 +190,8 @@ let rec insert_labels_app ~labels ~text args = let pos0 = arg.pexp_loc.Location.loc_start.Lexing.pos_cnum in let pos = insertion_point pos0 ~text in match arg.pexp_desc with - | Pexp_ident({ txt = Longident.Lident name }) when l = name && pos = pos0 -> + | Pexp_ident({ txt = Longident.Lident name }) + when l = name && pos = pos0 -> add_insertion pos "~" | _ -> add_insertion pos ("~" ^ l ^ ":") end; @@ -224,7 +225,9 @@ let rec add_labels_expr ~text ~values ~classes expr = end; List.iter args ~f:(fun (_,e) -> add_labels_rec e) | Pexp_apply ({pexp_desc=Pexp_send - ({pexp_desc=Pexp_ident({ txt = Longident.Lident s })},meth)}, args) -> + ({pexp_desc=Pexp_ident({ txt = Longident.Lident s })}, + meth)}, + args) -> begin try if SMap.find s values = ["<object>"] then let labels = SMap.find (s ^ "#" ^ meth) values in diff --git a/tools/check-typo b/tools/check-typo index eabd1c05d8..05c7c68c07 100755 --- a/tools/check-typo +++ b/tools/check-typo @@ -47,6 +47,9 @@ # *.clib # *.reference # */reference +# - Any file whose name matches one of the following patterns is +# automatically exempt from the "long-line" rule. +# *.reference # ASCII characters are bytes from 0 to 127. Any other byte is # flagged as a non-ASCII character. @@ -137,6 +140,9 @@ IGNORE_DIRS=" *.mlpack|*.mllib|*.mltop|*.odocl|*.itarget|*.clib) h;; *.reference|*/reference) h;; esac + case "$f" in + *.reference) rules="long-line,$rules";; + esac (cat "$f"; echo) \ | awk -v rules="$rules" -v svnrules="$svnrules" -v file="$f" \ diff --git a/tools/cmt2annot.ml b/tools/cmt2annot.ml index 9632e48b55..fd2a6c9502 100644 --- a/tools/cmt2annot.ml +++ b/tools/cmt2annot.ml @@ -23,7 +23,9 @@ let bind_variables scope = super # pattern pat; match pat.pat_desc with | Tpat_var (id, _) | Tpat_alias (_, id, _) -> - Stypes.record (Stypes.An_ident (pat.pat_loc, Ident.name id, Annot.Idef scope)) + Stypes.record (Stypes.An_ident (pat.pat_loc, + Ident.name id, + Annot.Idef scope)) | _ -> () end @@ -136,7 +138,8 @@ let binary_part iter x = | Partial_signature_item x -> iter # signature_item x | Partial_module_type x -> iter # module_type x -let gen_annot target_filename filename {Cmt_format.cmt_loadpath; cmt_annots; cmt_use_summaries; _} = +let gen_annot target_filename filename + {Cmt_format.cmt_loadpath; cmt_annots; cmt_use_summaries; _} = let open Cmt_format in Envaux.reset_cache (); Config.load_path := cmt_loadpath; @@ -152,7 +155,7 @@ let gen_annot target_filename filename {Cmt_format.cmt_loadpath; cmt_annots; cmt iterator # structure typedtree; Stypes.dump target_filename | Interface _ -> - Printf.fprintf stderr "Cannot generate annotations for interface file\n%!"; + Printf.eprintf "Cannot generate annotations for interface file\n%!"; exit 2 | Partial_implementation parts -> Array.iter (binary_part iterator) parts; diff --git a/tools/depend.ml b/tools/depend.ml index 7883f84917..1d74153dba 100644 --- a/tools/depend.ml +++ b/tools/depend.ml @@ -75,7 +75,10 @@ let add_type_declaration bv td = let add_tkind = function Ptype_abstract -> () | Ptype_variant cstrs -> - List.iter (fun (c, args, rty, _) -> List.iter (add_type bv) args; Misc.may (add_type bv) rty) cstrs + List.iter (fun (c, args, rty, _) -> + List.iter (add_type bv) args; + Misc.may (add_type bv) rty) + cstrs | Ptype_record lbls -> List.iter (fun (l, mut, ty, _) -> add_type bv ty) lbls in add_tkind td.ptype_kind @@ -234,7 +237,9 @@ and add_sig_item bv item = | Psig_module(id, mty) -> add_modtype bv mty; StringSet.add id.txt bv | Psig_recmodule decls -> - let bv' = List.fold_right StringSet.add (List.map (fun (x,_) -> x.txt) decls) bv in + let bv' = + List.fold_right StringSet.add (List.map (fun (x,_) -> x.txt) decls) bv + in List.iter (fun (id, mty) -> add_modtype bv' mty) decls; bv' | Psig_modtype(id,mtyd) -> diff --git a/tools/dumpobj.ml b/tools/dumpobj.ml index df654a94cc..b2af7884e1 100644 --- a/tools/dumpobj.ml +++ b/tools/dumpobj.ml @@ -541,7 +541,9 @@ let dump_exe ic = let arg_list = [ "-noloc", Arg.Clear print_locations, " : don't print source information"; ] -let arg_usage = Printf.sprintf "%s [OPTIONS] FILES : dump content of bytecode files" Sys.argv.(0) +let arg_usage = + Printf.sprintf "%s [OPTIONS] FILES : dump content of bytecode files" + Sys.argv.(0) let first_file = ref true diff --git a/tools/eqparsetree.ml b/tools/eqparsetree.ml index 454a3ddd21..10d631f024 100644 --- a/tools/eqparsetree.ml +++ b/tools/eqparsetree.ml @@ -12,8 +12,8 @@ (* - This module is mainly used to diff two parsetree, it helps to automate the test - for parsing/pprintast.ml + This module is mainly used to diff two parsetree, it helps to automate the + test for parsing/pprintast.ml *) @@ -38,7 +38,7 @@ let eq_option mf_a (x, y) = | (None, None) -> true | (Some x, Some y) -> mf_a (x, y) | (_, _) -> false - + module Location =struct include Location let eq_t : (t*t) -> bool = fun (_,_) -> true @@ -66,54 +66,54 @@ module Asttypes = struct | (Const_int64 a0, Const_int64 b0) -> eq_int64 (a0, b0) | (Const_nativeint a0, Const_nativeint b0) -> eq_nativeint (a0, b0) | (_, _) -> false - + let eq_rec_flag : (rec_flag * rec_flag) -> 'result = function | (Nonrecursive, Nonrecursive) -> true | (Recursive, Recursive) -> true | (Default, Default) -> true | (_, _) -> false - + let eq_direction_flag : (direction_flag * direction_flag) -> 'result = function | (Upto, Upto) -> true | (Downto, Downto) -> true | (_, _) -> false - + let eq_private_flag : (private_flag * private_flag) -> 'result = function | (Private, Private) -> true | (Public, Public) -> true | (_, _) -> false - + let eq_mutable_flag : (mutable_flag * mutable_flag) -> 'result = function | (Immutable, Immutable) -> true | (Mutable, Mutable) -> true | (_, _) -> false - + let eq_virtual_flag : (virtual_flag * virtual_flag) -> 'result = function | (Virtual, Virtual) -> true | (Concrete, Concrete) -> true | (_, _) -> false - + let eq_override_flag : (override_flag * override_flag) -> 'result = function | (Override, Override) -> true | (Fresh, Fresh) -> true | (_, _) -> false - + let eq_closed_flag : (closed_flag * closed_flag) -> 'result = function | (Closed, Closed) -> true | (Open, Open) -> true | (_, _) -> false - + let eq_label : (label * label) -> 'result = fun (a0, a1) -> eq_string (a0, a1) - + let eq_loc : 'all_a0. (('all_a0 * 'all_a0) -> 'result) -> @@ -777,5 +777,3 @@ and eq_toplevel_phrase : | (Ptop_dir (a0, a1), Ptop_dir (b0, b1)) -> (eq_string (a0, b0)) && (eq_directive_argument (a1, b1)) | (_, _) -> false - - diff --git a/tools/make-package-macosx b/tools/make-package-macosx index 657860e77b..1fa08919d2 100755 --- a/tools/make-package-macosx +++ b/tools/make-package-macosx @@ -84,7 +84,7 @@ mkdir -p resources # stop here -> | cat >resources/ReadMe.txt <<EOF This package installs OCaml version ${VERSION}. -You need Mac OS X 10.7.x (Lion), with the +You need Mac OS X 10.7.x (Lion) or later, with the XCode tools installed (v4.3.3 or later). Files will be installed in the following directories: diff --git a/tools/make-version-header.sh b/tools/make-version-header.sh index 22320ec16c..b5e69be956 100755 --- a/tools/make-version-header.sh +++ b/tools/make-version-header.sh @@ -30,13 +30,13 @@ version="`ocamlc -v | sed -n -e 's/.*version //p'`" major="`echo "$version" | sed -n -e '1s/^\([0-9]*\)\..*/\1/p'`" minor="`echo "$version" | sed -n -e '1s/^[0-9]*\.\([0-9]*\).*/\1/p'`" -patchlevel="`echo "$version" | sed -n -e '1s/^[0-9]*\.[0-9]*\.\([0-9]*\).*/\1/p'`" +patchlvl="`echo "$version" | sed -n -e '1s/^[0-9]*\.[0-9]*\.\([0-9]*\).*/\1/p'`" suffix="`echo "$version" | sed -n -e '1s/^[^+]*+\(.*\)/\1/p'`" echo "#define OCAML_VERSION_MAJOR $major" echo "#define OCAML_VERSION_MINOR $minor" -case $patchlevel in "") patchlevel=0;; esac -echo "#define OCAML_VERSION_PATCHLEVEL $patchlevel" +case $patchlvl in "") patchlvl=0;; esac +echo "#define OCAML_VERSION_PATCHLEVEL $patchlvl" case "$suffix" in "") echo "#undef OCAML_VERSION_ADDITIONAL";; *) echo "#define OCAML_VERSION_ADDITIONAL \"$suffix\"";; diff --git a/tools/objinfo.ml b/tools/objinfo.ml index 186d7f5ae9..eb88a8b29c 100644 --- a/tools/objinfo.ml +++ b/tools/objinfo.ml @@ -268,7 +268,8 @@ let dump_obj filename = end let arg_list = [] -let arg_usage = Printf.sprintf "%s [OPTIONS] FILES : give information on files" Sys.argv.(0) +let arg_usage = + Printf.sprintf "%s [OPTIONS] FILES : give information on files" Sys.argv.(0) let main() = Arg.parse arg_list dump_obj arg_usage; diff --git a/tools/objinfo_helper.c b/tools/objinfo_helper.c index 689cdf750e..58dfd2d459 100644 --- a/tools/objinfo_helper.c +++ b/tools/objinfo_helper.c @@ -85,7 +85,7 @@ int main(int argc, char ** argv) int main(int argc, char ** argv) { - fprintf(stderr, "BFD library unavailable, cannot print info on .cmxs files\n"); + fprintf(stderr,"BFD library unavailable, cannot print info on .cmxs files\n"); return 2; } diff --git a/tools/ocaml299to3.ml b/tools/ocaml299to3.ml index 8ff98a8f6f..a8eab92a99 100644 --- a/tools/ocaml299to3.ml +++ b/tools/ocaml299to3.ml @@ -124,7 +124,8 @@ let _ = print_endline "Convert OCaml 2.99 O'Labl-style labels in implementation files to"; print_endline - "a syntax compatible with version 3. Also `fun:' labels are replaced by `f:'."; + "a syntax compatible with version 3. Also `fun:' labels are replaced \ + by `f:'."; print_endline "Other syntactic changes are not handled."; print_endline "Old files are renamed to <file>.bak."; print_endline "Interface files do not need label syntax conversion."; diff --git a/tools/ocamlcp.ml b/tools/ocamlcp.ml index 256213e1fd..7e779eae10 100644 --- a/tools/ocamlcp.ml +++ b/tools/ocamlcp.ml @@ -74,10 +74,10 @@ module Options = Main_args.Make_bytecomp_options (struct let _pp s = incompatible "-pp" let _ppx s = incompatible "-ppx" let _principal = option "-principal" - let _short_paths = option "-short-paths" let _rectypes = option "-rectypes" let _nojoin () = option "-nojoin" () let _runtime_variant s = option_with_arg "-runtime-variant" s + let _short_paths = option "-short-paths" let _strict_sequence = option "-strict-sequence" let _thread () = option "-thread" () let _vmthread () = option "-vmthread" () diff --git a/tools/ocamldep.ml b/tools/ocamldep.ml index 9e368bf70b..8fb0c70027 100644 --- a/tools/ocamldep.ml +++ b/tools/ocamldep.ml @@ -13,7 +13,7 @@ open Compenv open Parsetree - +let ppf = Format.err_formatter (* Print the dependencies *) type file_kind = ML | MLI;; @@ -285,8 +285,9 @@ let ml_file_dependencies source_file = end let mli_file_dependencies source_file = - let extracted_deps = read_parse_and_extract - Parse.interface Depend.add_signature Config.ast_intf_magic_number source_file + let extracted_deps = + read_parse_and_extract Parse.interface Depend.add_signature + Config.ast_intf_magic_number source_file in if !sort_files then files := (source_file, MLI, extracted_deps) :: !files @@ -302,7 +303,7 @@ let mli_file_dependencies source_file = end let file_dependencies_as kind source_file = - Compenv.readenv Before_compile; + Compenv.readenv ppf Before_compile; load_path := []; List.iter add_to_load_path ( (!Compenv.last_include_dirs @ @@ -415,7 +416,7 @@ let print_version_num () = let _ = Clflags.classic := false; first_include_dirs := Filename.current_dir_name :: !first_include_dirs; - Compenv.readenv Before_args; + Compenv.readenv ppf Before_args; Arg.parse [ "-nojoin", Arg.Set Clflags.nojoin, "act over pure OCaml source files" ; @@ -441,7 +442,7 @@ let _ = " Output one line per file, regardless of the length"; "-pp", Arg.String(fun s -> Clflags.preprocessor := Some s), "<cmd> Pipe sources through preprocessor <cmd>"; - "-ppx", Arg.String(fun s -> first_ppx := s :: !first_ppx), + "-ppx", Arg.String(fun s -> first_ppx := s :: !first_ppx), "<cmd> Pipe abstract syntax trees through preprocessor <cmd>"; "-slash", Arg.Set Clflags.force_slash, " (Windows) Use forward slash / instead of backslash \\ in file paths"; @@ -452,6 +453,6 @@ let _ = "-vnum", Arg.Unit print_version_num, " Print version number and exit"; ] file_dependencies usage; - Compenv.readenv Before_link; + Compenv.readenv ppf Before_link; if !sort_files then sort_files_by_dependencies !files; exit (if !error_occurred then 2 else 0) diff --git a/tools/ocamlmklib.mlp b/tools/ocamlmklib.mlp index 972151447d..8c52b1363f 100644 --- a/tools/ocamlmklib.mlp +++ b/tools/ocamlmklib.mlp @@ -20,7 +20,8 @@ let compiler_path name = let bytecode_objs = ref [] (* .cmo,.cma,.ml,.mli files to pass to jocamlc *) and native_objs = ref [] (* .cmx,.cmxa,.ml,.mli files to pass to jocamlopt *) -and c_objs = ref [] (* .o, .a, .obj, .lib, .dll files to pass to mksharedlib and ar *) +and c_objs = ref [] (* .o, .a, .obj, .lib, .dll files to pass + to mksharedlib and ar *) and caml_libs = ref [] (* -cclib to pass to jocamlc, jocamlopt *) and caml_opts = ref [] (* -ccopt to pass to jocamlc, jocamlopt *) and dynlink = ref supports_shared_libraries @@ -142,7 +143,8 @@ let parse_arguments argv = if !output_c = "" then output_c := !output let usage = "\ -Usage: jocamlmklib [options] <.cmo|.cma|.cmx|.cmxa|.ml|.mli|.o|.a|.obj|.lib|.dll files>\ +Usage: jocamlmklib [options] <.cmo|.cma|.cmx|.cmxa|.ml|.mli|.o|.a|.obj|.lib|\ + .dll files>\ \nOptions are:\ \n -cclib <lib> C library passed to jocamlc -a or jocamlopt -a only\ \n -ccopt <opt> C option passed to jocamlc -a or jocamlopt -a only\ diff --git a/tools/ocamlmktop.ml b/tools/ocamlmktop.ml index ee21f76e40..06288d740b 100644 --- a/tools/ocamlmktop.ml +++ b/tools/ocamlmktop.ml @@ -12,4 +12,6 @@ let _ = let args = Ccomp.quote_files (List.tl (Array.to_list Sys.argv)) in - exit(Sys.command("ocamlc -I +compiler-libs -linkall ocamlcommon.cma ocamlbytecomp.cma ocamltoplevel.cma " ^ args ^ " topstart.cmo")) + exit(Sys.command("ocamlc -I +compiler-libs -linkall ocamlcommon.cma \ + ocamlbytecomp.cma ocamltoplevel.cma " + ^ args ^ " topstart.cmo")) diff --git a/tools/ocamlmktop.tpl b/tools/ocamlmktop.tpl index f6994da868..a6eef60ab5 100644 --- a/tools/ocamlmktop.tpl +++ b/tools/ocamlmktop.tpl @@ -11,4 +11,5 @@ # # ######################################################################### -exec %%BINDIR%%/jocamlc -I +compiler-libs -linkall ocamlcommon.cma ocamlbytecomp.cma ocamltoplevel.cma "$@" topstart.cmo +exec %%BINDIR%%/jocamlc -I +compiler-libs -linkall ocamlcommon.cma \ + ocamlbytecomp.cma ocamltoplevel.cma "$@" topstart.cmo diff --git a/tools/ocamloptp.ml b/tools/ocamloptp.ml index 1e47e16086..1832248347 100644 --- a/tools/ocamloptp.ml +++ b/tools/ocamloptp.ml @@ -76,10 +76,10 @@ module Options = Main_args.Make_optcomp_options (struct let _pp s = incompatible "-pp" let _ppx s = incompatible "-ppx" let _principal = option "-principal" - let _short_paths = option "-short-paths" let _rectypes = option "-rectypes" let _runtime_variant s = option_with_arg "-runtime-variant" s let _S = option "-S" + let _short_paths = option "-short-paths" let _strict_sequence = option "-strict-sequence" let _shared = option "-shared" let _thread = option "-thread" diff --git a/tools/untypeast.ml b/tools/untypeast.ml index 1f96771c97..8a440d82a9 100644 --- a/tools/untypeast.ml +++ b/tools/untypeast.ml @@ -153,10 +153,12 @@ and untype_exception_declaration decl = and untype_pattern pat = let desc = match pat with - { pat_extra=[Tpat_unpack, _]; pat_desc = Tpat_var (_,name); _ } -> Ppat_unpack name + { pat_extra=[Tpat_unpack, _]; pat_desc = Tpat_var (_,name); _ } -> + Ppat_unpack name | { pat_extra=[Tpat_type (_path, lid), _]; _ } -> Ppat_type lid | { pat_extra= (Tpat_constraint ct, _) :: rem; _ } -> - Ppat_constraint (untype_pattern { pat with pat_extra=rem }, untype_core_type ct) + Ppat_constraint (untype_pattern { pat with pat_extra=rem }, + untype_core_type ct) | _ -> match pat.pat_desc with Tpat_any -> Ppat_any @@ -177,6 +179,7 @@ and untype_pattern pat = Ppat_construct (lid, (match args with [] -> None + | [arg] -> Some (untype_pattern arg) | args -> Some { ppat_desc = Ppat_tuple (List.map untype_pattern args); ppat_loc = pat.pat_loc; } @@ -356,7 +359,7 @@ and untype_signature_item item = | Tsig_modtype (_id, name, mdecl) -> Psig_modtype (name, untype_modtype_declaration mdecl) | Tsig_open (ovf, _path, lid) -> Psig_open (ovf, lid) - | Tsig_include (mty, _lid) -> Psig_include (untype_module_type mty) + | Tsig_include (mty, _) -> Psig_include (untype_module_type mty) | Tsig_class list -> Psig_class (List.map untype_class_description list) | Tsig_class_type list -> @@ -448,7 +451,8 @@ and untype_module_expr mexpr = and untype_class_expr cexpr = let desc = match cexpr.cl_desc with - | Tcl_constraint ( { cl_desc = Tcl_ident (_path, lid, tyl); _ }, None, _, _, _ ) -> + | Tcl_constraint ( { cl_desc = Tcl_ident (_path, lid, tyl); _ }, + None, _, _, _ ) -> Pcl_constr (lid, List.map untype_core_type tyl) | Tcl_structure clstr -> Pcl_structure (untype_class_structure clstr) diff --git a/toplevel/opttoploop.ml b/toplevel/opttoploop.ml index e547bbd4d6..5dffe10e95 100644 --- a/toplevel/opttoploop.ml +++ b/toplevel/opttoploop.ml @@ -40,7 +40,9 @@ let need_symbol sym = with _ -> true let dll_run dll entry = - match (try Result (Obj.magic (ndl_run_toplevel dll entry)) with exn -> Exception exn) with + match (try Result (Obj.magic (ndl_run_toplevel dll entry)) + with exn -> Exception exn) + with | Exception _ as r -> r | Result r -> match Obj.magic r with diff --git a/toplevel/opttopmain.ml b/toplevel/opttopmain.ml index 968014c2db..43141e8c0d 100644 --- a/toplevel/opttopmain.ml +++ b/toplevel/opttopmain.ml @@ -12,7 +12,8 @@ open Clflags -let usage = "Usage: ocamlnat <options> <object-files> [script-file]\noptions are:" +let usage = + "Usage: ocamlnat <options> <object-files> [script-file]\noptions are:" let preload_objects = ref [] @@ -80,6 +81,7 @@ module Options = Main_args.Make_opttop_options (struct let _rectypes = set recursive_types let _strict_sequence = set strict_sequence let _S = set keep_asm_file + let _short_paths = clear real_paths let _stdin () = file_argument "" let _unsafe = set fast let _version () = print_version () @@ -87,7 +89,6 @@ module Options = Main_args.Make_opttop_options (struct let _w s = Warnings.parse_options false s let _warn_error s = Warnings.parse_options true s let _warn_help = Warnings.help_warnings - let _short_paths = clear real_paths let _dsource = set dump_source let _dparsetree = set dump_parsetree diff --git a/toplevel/topdirs.ml b/toplevel/topdirs.ml index da2729b583..6496607375 100644 --- a/toplevel/topdirs.ml +++ b/toplevel/topdirs.ml @@ -93,7 +93,9 @@ let load_compunit ic filename ppf compunit = end let rec load_file recursive ppf name = - let filename = try Some (find_in_path !Config.load_path name) with Not_found -> None in + let filename = + try Some (find_in_path !Config.load_path name) with Not_found -> None + in match filename with | None -> fprintf ppf "Cannot find file %s.@." name; false | Some filename -> @@ -117,11 +119,16 @@ and really_load_file recursive ppf name filename ic = if recursive then List.iter (function - | (Reloc_getglobal id, _) when not (Symtable.is_global_defined id) -> + | (Reloc_getglobal id, _) + when not (Symtable.is_global_defined id) -> let file = Ident.name id ^ ".cmo" in - begin match try Some (Misc.find_in_path_uncap !Config.load_path file) with Not_found -> None with + begin match try Some (Misc.find_in_path_uncap !Config.load_path + file) + with Not_found -> None + with | None -> () - | Some file -> if not (load_file recursive ppf file) then raise Load_failed + | Some file -> + if not (load_file recursive ppf file) then raise Load_failed end | _ -> () ) @@ -157,7 +164,8 @@ let _ = Hashtbl.add directive_table "load" (Directive_string (dir_load std_out)) let dir_load_rec ppf name = ignore (load_file true ppf name) -let _ = Hashtbl.add directive_table "load_rec" (Directive_string (dir_load_rec std_out)) +let _ = Hashtbl.add directive_table "load_rec" + (Directive_string (dir_load_rec std_out)) let load_file = load_file false @@ -167,7 +175,8 @@ let dir_use ppf name = ignore(Toploop.use_file ppf name) let dir_mod_use ppf name = ignore(Toploop.mod_use_file ppf name) let _ = Hashtbl.add directive_table "use" (Directive_string (dir_use std_out)) -let _ = Hashtbl.add directive_table "mod_use" (Directive_string (dir_mod_use std_out)) +let _ = Hashtbl.add directive_table "mod_use" + (Directive_string (dir_mod_use std_out)) (* Install, remove a printer *) diff --git a/toplevel/topmain.ml b/toplevel/topmain.ml index ba877e4df7..51465ed338 100644 --- a/toplevel/topmain.ml +++ b/toplevel/topmain.ml @@ -81,8 +81,8 @@ module Options = Main_args.Make_bytetop_options (struct let _nostdlib = set no_std_include let _ppx s = first_ppx := s :: !first_ppx let _principal = set principal - let _short_paths = clear real_paths let _rectypes = set recursive_types + let _short_paths = clear real_paths let _stdin () = file_argument "" let _strict_sequence = set strict_sequence let _unsafe = set fast @@ -104,8 +104,9 @@ end);; let main () = magic_join () ; - Compenv.readenv Before_args; + let ppf = Format.err_formatter in + Compenv.readenv ppf Before_args; Arg.parse Options.list file_argument usage; - Compenv.readenv Before_link; - if not (prepare Format.err_formatter) then exit 2; + Compenv.readenv ppf Before_link; + if not (prepare ppf) then exit 2; Toploop.loop Format.std_formatter diff --git a/typing/ctype.ml b/typing/ctype.ml index e0a451cd8f..2f81f049da 100644 --- a/typing/ctype.ml +++ b/typing/ctype.ml @@ -731,8 +731,8 @@ let rec update_level env level ty = set_level ty level; iter_type_expr (update_level env level) ty | Tfield(lab, _, ty1, _) - when lab = dummy_method && (repr ty1).level > level-> - raise (Unify [(ty, newvar2 level)]) + when lab = dummy_method && (repr ty1).level > level -> + raise (Unify [(ty1, newvar2 level)]) | _ -> set_level ty level; (* XXX what about abbreviations in Tconstr ? *) @@ -995,6 +995,12 @@ let rec copy ?env ?partial ?keep_names ty = if keep then more else newty more.desc | _ -> assert false in + let row = + match repr more' with (* PR#6163 *) + {desc=Tconstr _} when not row.row_fixed -> + {row with row_fixed = true} + | _ -> row + in (* Open row if partial for pattern and contains Reither *) let more', row = match partial with @@ -1448,7 +1454,7 @@ let rec extract_concrete_typedecl env ty = if decl.type_kind <> Type_abstract then (p, p, decl) else let ty = try try_expand_once env ty with Cannot_expand -> raise Not_found - in + in let (_, p', decl) = extract_concrete_typedecl env ty in (p, p', decl) | _ -> raise Not_found @@ -1890,19 +1896,19 @@ let reify env t = let t = create_fresh_constr ty.level name in link_type ty t | Tvariant r -> - let r = row_repr r in + let r = row_repr r in if not (static_row r) then begin - if r.row_fixed then iterator (row_more r) else - let m = r.row_more in - match m.desc with - Tvar o -> - let name = match o with Some s -> s | _ -> "ex" in - let t = create_fresh_constr m.level name in - let row = - {r with row_fields=[]; row_fixed=true; row_more = t} in - link_type m (newty2 m.level (Tvariant row)) - | _ -> assert false - end; + if r.row_fixed then iterator (row_more r) else + let m = r.row_more in + match m.desc with + Tvar o -> + let name = match o with Some s -> s | _ -> "ex" in + let t = create_fresh_constr m.level name in + let row = + {r with row_fields=[]; row_fixed=true; row_more = t} in + link_type m (newty2 m.level (Tvariant row)) + | _ -> assert false + end; iter_row iterator r | Tconstr (p, _, _) when is_object_type p -> iter_type_expr iterator (full_expand !env ty) @@ -1912,12 +1918,12 @@ let reify env t = in iterator t -let is_abstract_newtype env p = +let is_newtype env p = try let decl = Env.find_type p env in - not (decl.type_newtype_level = None) && - decl.type_manifest = None && - decl.type_kind = Type_abstract + decl.type_newtype_level <> None && + decl.type_kind = Type_abstract && + decl.type_private = Public with Not_found -> false let non_aliasable p decl = @@ -1932,78 +1938,78 @@ let non_aliasable p decl = and that both their objects and variants are closed *) -let rec mcomp type_pairs subst env t1 t2 = +let rec mcomp type_pairs env t1 t2 = if t1 == t2 then () else let t1 = repr t1 in let t2 = repr t2 in if t1 == t2 then () else - match (t1.desc, t2.desc) with - | (Tvar _, _) - | (_, Tvar _) -> - fatal_error "types should not include variables" - | (Tconstr (p1, [], _), Tconstr (p2, [], _)) when Path.same p1 p2 -> - () - | _ -> - let t1' = expand_head_opt env t1 in - let t2' = expand_head_opt env t2 in - (* Expansion may have changed the representative of the types... *) - let t1' = repr t1' and t2' = repr t2' in - if t1' == t2' then () else - begin try TypePairs.find type_pairs (t1', t2') - with Not_found -> - TypePairs.add type_pairs (t1', t2') (); - match (t1'.desc, t2'.desc) with - (Tvar _, Tvar _) -> assert false - | (Tarrow (l1, t1, u1, _), Tarrow (l2, t2, u2, _)) - when l1 = l2 || not (is_optional l1 || is_optional l2) -> - mcomp type_pairs subst env t1 t2; - mcomp type_pairs subst env u1 u2; - | (Ttuple tl1, Ttuple tl2) -> - mcomp_list type_pairs subst env tl1 tl2 - | (Tconstr (p1, tl1, _), Tconstr (p2, tl2, _)) -> - mcomp_type_decl type_pairs subst env p1 p2 tl1 tl2 - | (Tconstr (p, _, _), _) | (_, Tconstr (p, _, _)) -> - let decl = Env.find_type p env in - if non_aliasable p decl then raise (Unify []) - | (Tpackage (p1, n1, tl1), Tpackage (p2, n2, tl2)) - when Path.same p1 p2 && n1 = n2 -> - mcomp_list type_pairs subst env tl1 tl2 - | (Tvariant row1, Tvariant row2) -> - mcomp_row type_pairs subst env row1 row2 - | (Tobject (fi1, _), Tobject (fi2, _)) -> - mcomp_fields type_pairs subst env fi1 fi2 - | (Tfield _, Tfield _) -> (* Actually unused *) - mcomp_fields type_pairs subst env t1' t2' - | (Tnil, Tnil) -> - () - | (Tpoly (t1, []), Tpoly (t2, [])) -> - mcomp type_pairs subst env t1 t2 - | (Tpoly (t1, tl1), Tpoly (t2, tl2)) -> - enter_poly env univar_pairs t1 tl1 t2 tl2 - (mcomp type_pairs subst env) - | (Tunivar _, Tunivar _) -> - unify_univar t1' t2' !univar_pairs - | (_, _) -> - raise (Unify []) - end + match (t1.desc, t2.desc) with + | (Tvar _, _) + | (_, Tvar _) -> + () + | (Tconstr (p1, [], _), Tconstr (p2, [], _)) when Path.same p1 p2 -> + () + | _ -> + let t1' = expand_head_opt env t1 in + let t2' = expand_head_opt env t2 in + (* Expansion may have changed the representative of the types... *) + let t1' = repr t1' and t2' = repr t2' in + if t1' == t2' then () else + begin try TypePairs.find type_pairs (t1', t2') + with Not_found -> + TypePairs.add type_pairs (t1', t2') (); + match (t1'.desc, t2'.desc) with + (Tvar _, Tvar _) -> assert false + | (Tarrow (l1, t1, u1, _), Tarrow (l2, t2, u2, _)) + when l1 = l2 || not (is_optional l1 || is_optional l2) -> + mcomp type_pairs env t1 t2; + mcomp type_pairs env u1 u2; + | (Ttuple tl1, Ttuple tl2) -> + mcomp_list type_pairs env tl1 tl2 + | (Tconstr (p1, tl1, _), Tconstr (p2, tl2, _)) -> + mcomp_type_decl type_pairs env p1 p2 tl1 tl2 + | (Tconstr (p, _, _), _) | (_, Tconstr (p, _, _)) -> + let decl = Env.find_type p env in + if non_aliasable p decl then raise (Unify []) + | (Tpackage (p1, n1, tl1), Tpackage (p2, n2, tl2)) + when Path.same p1 p2 && n1 = n2 -> + mcomp_list type_pairs env tl1 tl2 + | (Tvariant row1, Tvariant row2) -> + mcomp_row type_pairs env row1 row2 + | (Tobject (fi1, _), Tobject (fi2, _)) -> + mcomp_fields type_pairs env fi1 fi2 + | (Tfield _, Tfield _) -> (* Actually unused *) + mcomp_fields type_pairs env t1' t2' + | (Tnil, Tnil) -> + () + | (Tpoly (t1, []), Tpoly (t2, [])) -> + mcomp type_pairs env t1 t2 + | (Tpoly (t1, tl1), Tpoly (t2, tl2)) -> + enter_poly env univar_pairs t1 tl1 t2 tl2 + (mcomp type_pairs env) + | (Tunivar _, Tunivar _) -> + unify_univar t1' t2' !univar_pairs + | (_, _) -> + raise (Unify []) + end -and mcomp_list type_pairs subst env tl1 tl2 = +and mcomp_list type_pairs env tl1 tl2 = if List.length tl1 <> List.length tl2 then raise (Unify []); - List.iter2 (mcomp type_pairs subst env) tl1 tl2 + List.iter2 (mcomp type_pairs env) tl1 tl2 -and mcomp_fields type_pairs subst env ty1 ty2 = +and mcomp_fields type_pairs env ty1 ty2 = if not (concrete_object ty1 && concrete_object ty2) then assert false; let (fields2, rest2) = flatten_fields ty2 in let (fields1, rest1) = flatten_fields ty1 in let (pairs, miss1, miss2) = associate_fields fields1 fields2 in - mcomp type_pairs subst env rest1 rest2; + mcomp type_pairs env rest1 rest2; if miss1 <> [] && (object_row ty1).desc = Tnil || miss2 <> [] && (object_row ty2).desc = Tnil then raise (Unify []); List.iter (function (n, k1, t1, k2, t2) -> mcomp_kind k1 k2; - mcomp type_pairs subst env t1 t2) + mcomp type_pairs env t1 t2) pairs and mcomp_kind k1 k2 = @@ -2014,7 +2020,7 @@ and mcomp_kind k1 k2 = | (Fpresent, Fpresent) -> () | _ -> raise (Unify []) -and mcomp_row type_pairs subst env row1 row2 = +and mcomp_row type_pairs env row1 row2 = let row1 = row_repr row1 and row2 = row_repr row2 in let r1, r2, pairs = merge_row_fields row1.row_fields row2.row_fields in let cannot_erase (_,f) = @@ -2033,21 +2039,21 @@ and mcomp_row type_pairs subst env row1 row2 = | (Reither (true, _, _, _) | Rabsent), Rpresent (Some _) -> raise (Unify []) | Rpresent(Some t1), Rpresent(Some t2) -> - mcomp type_pairs subst env t1 t2 + mcomp type_pairs env t1 t2 | Rpresent(Some t1), Reither(false, tl2, _, _) -> - List.iter (mcomp type_pairs subst env t1) tl2 + List.iter (mcomp type_pairs env t1) tl2 | Reither(false, tl1, _, _), Rpresent(Some t2) -> - List.iter (mcomp type_pairs subst env t2) tl1 + List.iter (mcomp type_pairs env t2) tl1 | _ -> ()) pairs -and mcomp_type_decl type_pairs subst env p1 p2 tl1 tl2 = +and mcomp_type_decl type_pairs env p1 p2 tl1 tl2 = try let decl = Env.find_type p1 env in let decl' = Env.find_type p2 env in if Path.same p1 p2 then begin (* Format.eprintf "@[%a@ %a@]@." - !print_raw (newconstr p1 tl2) !print_raw (newconstr p2 tl2); + !print_raw (newconstr p1 tl2) !print_raw (newconstr p2 tl2); if non_aliasable p1 decl then Format.eprintf "non_aliasable@." else Format.eprintf "aliasable@."; *) let inj = @@ -2055,16 +2061,16 @@ and mcomp_type_decl type_pairs subst env p1 p2 tl1 tl2 = with Not_found -> List.map (fun _ -> false) tl1 in List.iter2 - (fun i (t1,t2) -> if i then mcomp type_pairs subst env t1 t2) + (fun i (t1,t2) -> if i then mcomp type_pairs env t1 t2) inj (List.combine tl1 tl2) end else match decl.type_kind, decl'.type_kind with | Type_record (lst,r), Type_record (lst',r') when r = r' -> - mcomp_list type_pairs subst env tl1 tl2; - mcomp_record_description type_pairs subst env lst lst' + mcomp_list type_pairs env tl1 tl2; + mcomp_record_description type_pairs env lst lst' | Type_variant v1, Type_variant v2 -> - mcomp_list type_pairs subst env tl1 tl2; - mcomp_variant_description type_pairs subst env v1 v2 + mcomp_list type_pairs env tl1 tl2; + mcomp_variant_description type_pairs env v1 v2 | Type_variant _, Type_record _ | Type_record _, Type_variant _ -> raise (Unify []) | _ -> @@ -2072,18 +2078,18 @@ and mcomp_type_decl type_pairs subst env p1 p2 tl1 tl2 = || is_datatype decl && non_aliasable p2 decl' then raise (Unify []) with Not_found -> () -and mcomp_type_option type_pairs subst env t t' = +and mcomp_type_option type_pairs env t t' = match t, t' with None, None -> () - | Some t, Some t' -> mcomp type_pairs subst env t t' + | Some t, Some t' -> mcomp type_pairs env t t' | _ -> raise (Unify []) -and mcomp_variant_description type_pairs subst env xs ys = +and mcomp_variant_description type_pairs env xs ys = let rec iter = fun x y -> match x, y with (id, tl, t) :: xs, (id', tl', t') :: ys -> - mcomp_type_option type_pairs subst env t t'; - mcomp_list type_pairs subst env tl tl'; + mcomp_type_option type_pairs env t t'; + mcomp_list type_pairs env tl tl'; if Ident.name id = Ident.name id' then iter xs ys else raise (Unify []) @@ -2092,11 +2098,11 @@ and mcomp_variant_description type_pairs subst env xs ys = in iter xs ys -and mcomp_record_description type_pairs subst env = +and mcomp_record_description type_pairs env = let rec iter = fun x y -> match x, y with (id, mutable_flag, t) :: xs, (id', mutable_flag', t') :: ys -> - mcomp type_pairs subst env t t'; + mcomp type_pairs env t t'; if Ident.name id = Ident.name id' && mutable_flag = mutable_flag' then iter xs ys else raise (Unify []) @@ -2106,7 +2112,7 @@ and mcomp_record_description type_pairs subst env = iter let mcomp env t1 t2 = - mcomp (TypePairs.create 4) () env t1 t2 + mcomp (TypePairs.create 4) env t1 t2 (* Real unification *) @@ -2189,6 +2195,18 @@ let rec unify (env:Env.t ref) t1 t2 = || has_cached_expansion p2 !a2) -> update_level !env t1.level t2; link_type t1 t2 + | (Tconstr (p1, [], _), Tconstr (p2, [], _)) + when Env.has_local_constraints !env + && is_newtype !env p1 && is_newtype !env p2 -> + (* Do not use local constraints more than necessary *) + begin try + if find_newtype_level !env p1 < find_newtype_level !env p2 then + unify env t1 (try_expand_once !env t2) + else + unify env (try_expand_once !env t1) t2 + with Cannot_expand -> + unify2 env t1 t2 + end | _ -> unify2 env t1 t2 end; @@ -2301,7 +2319,7 @@ and unify3 env t1 t1' t2 t2' = inj (List.combine tl1 tl2) | (Tconstr ((Path.Pident p) as path,[],_), Tconstr ((Path.Pident p') as path',[],_)) - when is_abstract_newtype !env path && is_abstract_newtype !env path' + when is_newtype !env path && is_newtype !env path' && !generate_equations -> let source,destination = if find_newtype_level !env path > find_newtype_level !env path' @@ -2309,12 +2327,12 @@ and unify3 env t1 t1' t2 t2' = else p',t1' in add_gadt_equation env source destination | (Tconstr ((Path.Pident p) as path,[],_), _) - when is_abstract_newtype !env path && !generate_equations -> + when is_newtype !env path && !generate_equations -> reify env t2'; local_non_recursive_abbrev !env (Path.Pident p) t2'; add_gadt_equation env p t2' | (_, Tconstr ((Path.Pident p) as path,[],_)) - when is_abstract_newtype !env path && !generate_equations -> + when is_newtype !env path && !generate_equations -> reify env t1' ; local_non_recursive_abbrev !env (Path.Pident p) t1'; add_gadt_equation env p t1' @@ -2892,13 +2910,8 @@ and moregen_row inst_nongen type_pairs env row1 row2 = raise (Unify []) | _ when static_row row1 -> () | _ when may_inst -> - if not (static_row row2) then moregen_occur env rm1.level rm2; - let ext = - if r2 = [] then rm2 else - let row_ext = {row2 with row_fields = r2} in - iter_row (moregen_occur env rm1.level) row_ext; - newty2 rm1.level (Tvariant row_ext) - in + let ext = newgenty (Tvariant {row2 with row_fields = r2}) in + moregen_occur env rm1.level ext; link_type rm1 ext | Tconstr _, Tconstr _ -> moregen inst_nongen type_pairs env rm1 rm2 diff --git a/typing/env.ml b/typing/env.ml index 84670d755f..8316eb53ef 100644 --- a/typing/env.ml +++ b/typing/env.ml @@ -314,7 +314,7 @@ let read_pers_struct modname filename = ( ps_comps = comps; ps_crcs = crcs; ps_filename = filename; - ps_flags = flags } in + ps_flags = flags } in if ps.ps_name <> modname then raise(Error(Illegal_renaming(modname, ps.ps_name, filename))); check_consistency filename ps.ps_crcs; @@ -848,7 +848,7 @@ let rec find_shadowed_comps path env = | Pdot (p, s, _) -> let l = find_shadowed_comps p env in let l' = - List.map (find_all_comps (fun comps -> comps.comp_components) s) l in + List.map (find_all_comps (fun comps -> comps.comp_components) s) l in List.flatten l' | Papply _ -> [] @@ -1189,15 +1189,18 @@ and store_type slot id path info env renv = { env with constrs = List.fold_right - (fun (id, descr) constrs -> EnvTbl.add "constructor" slot id descr constrs renv.constrs) + (fun (id, descr) constrs -> + EnvTbl.add "constructor" slot id descr constrs renv.constrs) constructors env.constrs; labels = List.fold_right - (fun (id, descr) labels -> EnvTbl.add "label" slot id descr labels renv.labels) + (fun (id, descr) labels -> + EnvTbl.add "label" slot id descr labels renv.labels) labels env.labels; - types = EnvTbl.add "type" slot id (path, (info, descrs)) env.types renv.types; + types = EnvTbl.add "type" slot id (path, (info, descrs)) env.types + renv.types; summary = Env_type(env.summary, id, info) } and store_type_infos slot id path info env renv = @@ -1207,7 +1210,8 @@ and store_type_infos slot id path info env renv = keep track of type abbreviations (e.g. type t = float) in the computation of label representations. *) { env with - types = EnvTbl.add "type" slot id (path, (info,([],[]))) env.types renv.types; + types = EnvTbl.add "type" slot id (path, (info,([],[]))) env.types + renv.types; summary = Env_type(env.summary, id, info) } and store_exception slot id path decl env renv = @@ -1232,20 +1236,24 @@ and store_exception slot id path decl env renv = end; end; { env with - constrs = EnvTbl.add "constructor" slot id (Datarepr.exception_descr path decl) env.constrs renv.constrs; + constrs = EnvTbl.add "constructor" slot id + (Datarepr.exception_descr path decl) env.constrs + renv.constrs; summary = Env_exception(env.summary, id, decl) } and store_module slot id path mty env renv = { env with modules = EnvTbl.add "module" slot id (path, mty) env.modules renv.modules; components = - EnvTbl.add "module" slot id (path, components_of_module env Subst.identity path mty) + EnvTbl.add "module" slot id + (path, components_of_module env Subst.identity path mty) env.components renv.components; summary = Env_module(env.summary, id, mty) } and store_modtype slot id path info env renv = { env with - modtypes = EnvTbl.add "module type" slot id (path, info) env.modtypes renv.modtypes; + modtypes = EnvTbl.add "module type" slot id (path, info) env.modtypes + renv.modtypes; summary = Env_modtype(env.summary, id, info) } and store_class slot id path desc env renv = @@ -1255,7 +1263,8 @@ and store_class slot id path desc env renv = and store_cltype slot id path desc env renv = { env with - cltypes = EnvTbl.add "class type" slot id (path, desc) env.cltypes renv.cltypes; + cltypes = EnvTbl.add "class type" slot id (path, desc) env.cltypes + renv.cltypes; summary = Env_cltype(env.summary, id, desc) } (*>JOCAML *) @@ -1397,7 +1406,10 @@ let open_pers_signature name env = open_signature None (Pident(Ident.create_persistent name)) ps.ps_sig env let open_signature ?(loc = Location.none) ?(toplevel = false) ovf root sg env = - if not toplevel && ovf = Asttypes.Fresh && not loc.Location.loc_ghost && (Warnings.is_active (Warnings.Unused_open "") || Warnings.is_active (Warnings.Open_shadow_identifier ("", ""))) + if not toplevel && ovf = Asttypes.Fresh && not loc.Location.loc_ghost + && (Warnings.is_active (Warnings.Unused_open "") + || Warnings.is_active (Warnings.Open_shadow_identifier ("", "")) + || Warnings.is_active (Warnings.Open_shadow_label_constructor ("",""))) then begin let used = ref false in !add_delayed_check_forward @@ -1409,7 +1421,13 @@ let open_signature ?(loc = Location.none) ?(toplevel = false) ovf root sg env = let slot kind s b = if b && not (List.mem (kind, s) !shadowed) then begin shadowed := (kind, s) :: !shadowed; - Location.prerr_warning loc (Warnings.Open_shadow_identifier (kind, s)); + let w = + match kind with + | "label" | "constructor" -> + Warnings.Open_shadow_label_constructor (kind, s) + | _ -> Warnings.Open_shadow_identifier (kind, s) + in + Location.prerr_warning loc w end; used := true in @@ -1611,7 +1629,7 @@ open Format let report_error ppf = function | Illegal_renaming(name, modname, 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 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 8fc87489cb..690b185280 100644 --- a/typing/env.mli +++ b/typing/env.mli @@ -114,7 +114,9 @@ val remove_continuations: t -> t (* Insertion of all fields of a signature, relative to the given path. Used to implement open. *) -val open_signature: ?loc:Location.t -> ?toplevel:bool -> Asttypes.override_flag -> Path.t -> signature -> t -> t +val open_signature: + ?loc:Location.t -> ?toplevel:bool -> Asttypes.override_flag -> Path.t -> + signature -> t -> t val open_pers_signature: string -> t -> t (* Insertion by name *) diff --git a/typing/envaux.ml b/typing/envaux.ml index 30146be1ed..5e8b524e44 100644 --- a/typing/envaux.ml +++ b/typing/envaux.ml @@ -41,19 +41,26 @@ let rec env_from_summary sum subst = Env_empty -> Env.empty | Env_value(s, id, desc) -> - Env.add_value id (Subst.value_description subst desc) (env_from_summary s subst) + Env.add_value id (Subst.value_description subst desc) + (env_from_summary s subst) | Env_type(s, id, desc) -> - Env.add_type id (Subst.type_declaration subst desc) (env_from_summary s subst) + Env.add_type id (Subst.type_declaration subst desc) + (env_from_summary s subst) | Env_exception(s, id, desc) -> - Env.add_exception id (Subst.exception_declaration subst desc) (env_from_summary s subst) + Env.add_exception id (Subst.exception_declaration subst desc) + (env_from_summary s subst) | Env_module(s, id, desc) -> - Env.add_module id (Subst.modtype subst desc) (env_from_summary s subst) + Env.add_module id (Subst.modtype subst desc) + (env_from_summary s subst) | Env_modtype(s, id, desc) -> - Env.add_modtype id (Subst.modtype_declaration subst desc) (env_from_summary s subst) + Env.add_modtype id (Subst.modtype_declaration subst desc) + (env_from_summary s subst) | Env_class(s, id, desc) -> - Env.add_class id (Subst.class_declaration subst desc) (env_from_summary s subst) + Env.add_class id (Subst.class_declaration subst desc) + (env_from_summary s subst) | Env_cltype (s, id, desc) -> - Env.add_cltype id (Subst.cltype_declaration subst desc) (env_from_summary s subst) + Env.add_cltype id (Subst.cltype_declaration subst desc) + (env_from_summary s subst) | Env_open(s, path) -> let env = env_from_summary s subst in let path' = Subst.module_path subst path in diff --git a/typing/includecore.ml b/typing/includecore.ml index fa46b39078..802dda3b19 100644 --- a/typing/includecore.ml +++ b/typing/includecore.ml @@ -122,12 +122,6 @@ type type_mismatch = | Field_missing of bool * Ident.t | Record_representation of bool -let nth n = - if n = 1 then "first" else - if n = 2 then "2nd" else - if n = 3 then "3rd" else - string_of_int n ^ "th" - let report_type_mismatch0 first second decl ppf err = let pr fmt = Format.fprintf ppf fmt in match err with @@ -144,8 +138,8 @@ let report_type_mismatch0 first second decl ppf err = | Field_arity s -> pr "The arities for field %s differ" (Ident.name s) | Field_names (n, name1, name2) -> - pr "Their %s fields have different names, %s and %s" - (nth n) (Ident.name name1) (Ident.name name2) + pr "Fields number %i have different names, %s and %s" + n (Ident.name name1) (Ident.name name2) | Field_missing (b, s) -> pr "The field %s is only present in %s %s" (Ident.name s) (if b then second else first) decl diff --git a/typing/oprint.ml b/typing/oprint.ml index 96af79826d..3eeb654683 100644 --- a/typing/oprint.ml +++ b/typing/oprint.ml @@ -22,7 +22,8 @@ let cautious f ppf arg = let rec print_ident ppf = function Oide_ident s -> pp_print_string ppf s - | Oide_dot (id, s) -> print_ident ppf id; pp_print_char ppf '.'; pp_print_string ppf s + | Oide_dot (id, s) -> + print_ident ppf id; pp_print_char ppf '.'; pp_print_string ppf s | Oide_apply (id1, id2) -> fprintf ppf "%a(%a)" print_ident id1 print_ident id2 diff --git a/typing/printtyp.ml b/typing/printtyp.ml index d178b3e250..6c7a62c2e5 100644 --- a/typing/printtyp.ml +++ b/typing/printtyp.ml @@ -1226,7 +1226,7 @@ let rec filter_trace keep_last = function let rec type_path_list ppf = function | [tp, tp'] -> type_path_expansion tp ppf tp' - | (tp, tp') :: rem -> + | (tp, tp') :: rem -> fprintf ppf "%a@;<2 0>%a" (type_path_expansion tp) tp' type_path_list rem @@ -1431,12 +1431,12 @@ let report_subtyping_error ppf env tr1 txt1 tr2 = let report_ambiguous_type_error ppf env (tp0, tp0') tpl txt1 txt2 txt3 = wrap_printing_env env (fun () -> reset (); - List.iter - (fun (tp, tp') -> path_same_name tp0 tp; path_same_name tp0' tp') + List.iter + (fun (tp, tp') -> path_same_name tp0 tp; path_same_name tp0' tp') tpl; match tpl with [] -> assert false - | [tp, tp'] -> + | [tp, tp'] -> fprintf ppf "@[%t@;<1 2>%a@ \ %t@;<1 2>%a\ diff --git a/typing/printtyp.mli b/typing/printtyp.mli index e319f18f1f..7fa00ff44d 100644 --- a/typing/printtyp.mli +++ b/typing/printtyp.mli @@ -76,7 +76,7 @@ val report_subtyping_error: formatter -> Env.t -> (type_expr * type_expr) list -> string -> (type_expr * type_expr) list -> unit val report_ambiguous_type_error: - formatter -> Env.t -> (Path.t * Path.t) -> (Path.t * Path.t) list -> + formatter -> Env.t -> (Path.t * Path.t) -> (Path.t * Path.t) list -> (formatter -> unit) -> (formatter -> unit) -> (formatter -> unit) -> unit (* for toploop *) diff --git a/typing/printtyped.mli b/typing/printtyped.mli index c6c17a63cd..f0e8c1ed86 100644 --- a/typing/printtyped.mli +++ b/typing/printtyped.mli @@ -18,4 +18,5 @@ open Format;; val interface : formatter -> signature -> unit;; val implementation : formatter -> structure -> unit;; -val implementation_with_coercion : formatter -> (structure * module_coercion) -> unit;; +val implementation_with_coercion : + formatter -> (structure * module_coercion) -> unit;; diff --git a/typing/stypes.ml b/typing/stypes.ml index 6c9a1df23e..e1f4557a2c 100644 --- a/typing/stypes.ml +++ b/typing/stypes.ml @@ -156,7 +156,8 @@ let print_info pp prev_loc ti = printtyp_reset_maybe loc; Printtyp.mark_loops typ; Format.pp_print_string Format.str_formatter " "; - Printtyp.wrap_printing_env env (fun () -> Printtyp.type_sch Format.str_formatter typ); + Printtyp.wrap_printing_env env + (fun () -> Printtyp.type_sch Format.str_formatter typ); Format.pp_print_newline Format.str_formatter (); let s = Format.flush_str_formatter () in output_string pp s; diff --git a/typing/typeclass.ml b/typing/typeclass.ml index 707440ea06..db5bbde5b5 100644 --- a/typing/typeclass.ml +++ b/typing/typeclass.ml @@ -498,7 +498,8 @@ let class_type env scty = (*******************************) let rec class_field self_loc cl_num self_type meths vars - (val_env, met_env, par_env, fields, concr_meths, warn_vals, inher, local_meths, local_vals) + (val_env, met_env, par_env, fields, concr_meths, warn_vals, inher, + local_meths, local_vals) cf = let loc = cf.pcf_loc in match cf.pcf_desc with @@ -1225,8 +1226,11 @@ let class_infos define_class kind Ctype.end_def (); let sty = Ctype.self_type typ in - ignore (Ctype.object_fields sty); + (* First generalize the type of the dummy method (cf PR#6123) *) + let (fields, _) = Ctype.flatten_fields (Ctype.object_fields sty) in + List.iter (fun (met, _, ty) -> if met = dummy_method then Ctype.generalize ty) + fields; (* Generalize the row variable *) let rv = Ctype.row_variable sty in List.iter (Ctype.limited_generalize rv) params; diff --git a/typing/typecore.ml b/typing/typecore.ml index 2d6ae6821a..efb720af0d 100644 --- a/typing/typecore.ml +++ b/typing/typecore.ml @@ -565,7 +565,7 @@ let rec expand_path env p = match decl with Some {type_manifest = Some ty} -> begin match repr ty with - {desc=Tconstr(p,_,_)} -> expand_path env p + {desc=Tconstr(p,_,_)} -> expand_path env p | _ -> assert false end | _ -> p @@ -594,8 +594,8 @@ end) = struct let spellcheck ppf env p lid = Typetexp.spellcheck_simple ppf fold (fun d -> - if compare_type_path env p (get_type_path env d) - then get_name d else "") env lid + if compare_type_path env p (get_type_path env d) + then get_name d else "") env lid let lookup_from_type env tpath lid = let descrs = get_descrs (Env.find_type_descrs tpath env) in @@ -604,7 +604,7 @@ end) = struct Longident.Lident s -> begin try List.find (fun nd -> get_name nd = s) descrs - with Not_found -> + with Not_found -> raise (Error (lid.loc, env, Wrong_name (type_kind, tpath, lid.txt))) end | _ -> raise Not_found @@ -636,24 +636,24 @@ end) = struct let scope = match scope with None -> lbls | Some l -> l in let lbl = match opath with None -> - begin match lbls with + begin match lbls with [] -> unbound_name_error env lid - | (lbl, use) :: rest -> - use (); + | (lbl, use) :: rest -> + use (); let paths = ambiguous_types env lbl rest in - if paths <> [] then - warn lid.loc - (Warnings.Ambiguous_name ([Longident.last lid.txt], + if paths <> [] then + warn lid.loc + (Warnings.Ambiguous_name ([Longident.last lid.txt], paths, false)); - lbl - end + lbl + end | Some(tpath0, tpath, pr) -> - let warn_pr () = - let kind = if type_kind = "record" then "field" else "constructor" in + let warn_pr () = + let kind = if type_kind = "record" then "field" else "constructor" in warn lid.loc (Warnings.Not_principal - ("this type-based " ^ kind ^ " disambiguation")) - in + ("this type-based " ^ kind ^ " disambiguation")) + in try let lbl, use = disambiguate_by_type env tpath scope in use (); @@ -680,12 +680,12 @@ end) = struct (Warnings.Name_out_of_scope (s, [Longident.last lid.txt], false)); if not pr then warn_pr (); lbl - with Not_found -> + with Not_found -> if lbls = [] then unbound_name_error env lid else let tp = (tpath0, expand_path env tpath) in - let tpl = - List.map - (fun (lbl, _) -> + let tpl = + List.map + (fun (lbl, _) -> let tp0 = get_type_path env lbl in let tp = expand_path env tp0 in (tp0, tp)) @@ -973,10 +973,10 @@ let rec type_pat ~constrs ~labels ~no_existentials ~mode ~env sp expected_ty = pat_env = !env } | Ppat_construct(lid, sarg, explicit_arity) -> let opath = - try + try let (p0, p, _) = extract_concrete_variant !env expected_ty in Some (p0, p, true) - with Not_found -> None + with Not_found -> None in let constrs = match lid.txt, constrs with @@ -985,7 +985,7 @@ let rec type_pat ~constrs ~labels ~no_existentials ~mode ~env sp expected_ty = | _ -> Typetexp.find_all_constructors !env lid.loc lid.txt in let check_lk tpath constr = - if constr.cstr_generalized then + if constr.cstr_generalized then raise (Error (lid.loc, !env, Unqualified_gadt_pattern (tpath, constr.cstr_name))) in @@ -1046,7 +1046,7 @@ let rec type_pat ~constrs ~labels ~no_existentials ~mode ~env sp expected_ty = try let (p0, p,_) = extract_concrete_record !env expected_ty in Some (p0, p, true), expected_ty - with Not_found -> None, newvar () + with Not_found -> None, newvar () in let type_label_pat (label_lid, label, sarg) = begin_def (); @@ -1056,7 +1056,7 @@ let rec type_pat ~constrs ~labels ~no_existentials ~mode ~env sp expected_ty = unify_pat_types loc !env ty_res record_ty with Unify trace -> raise(Error(label_lid.loc, !env, - Label_mismatch(label_lid.txt, trace))) + Label_mismatch(label_lid.txt, trace))) end; let arg = type_pat sarg ty_arg in if vars <> [] then begin @@ -1450,6 +1450,9 @@ let rec is_nonexpansive exp = | Texp_function _ -> true | Texp_apply(e, (_,None,_)::el) -> is_nonexpansive e && List.for_all is_nonexpansive_opt (List.map snd3 el) + | Texp_match(e, pat_exp_list, _) -> + is_nonexpansive e && + List.for_all (fun (pat, exp) -> is_nonexpansive exp) pat_exp_list | Texp_tuple el -> List.for_all is_nonexpansive el | Texp_construct( _, _, el,_) -> @@ -1861,7 +1864,7 @@ let create_package_type loc env (p, l) = (* Helpers for type_cases *) let contains_variant_either ty = - let rec loop ty = + let rec loop ty = let ty = repr ty in if ty.level >= lowest_level then begin mark_type_node ty; @@ -1931,7 +1934,7 @@ let check_absent_variant env = unify_pat env {pat with pat_type = newty (Tvariant row')} (correct_levels pat.pat_type) | _ -> ()) - + let dummy_expr = {pexp_desc = Pexp_tuple []; pexp_loc = Location.none} @@ -2353,15 +2356,15 @@ and do_type_expect_ ?in_function ctx env sexp ty_expected = in let ty_record, opath = let get_path ty = - try - let (p0, p,_) = extract_concrete_record env ty in - (* XXX level may be wrong *) + try + let (p0, p,_) = extract_concrete_record env ty in + (* XXX level may be wrong *) Some (p0, p, ty.level = generic_level || not !Clflags.principal) with Not_found -> None in match get_path ty_expected with None -> - let op = + let op = match opt_exp with None -> None | Some exp -> get_path exp.exp_type @@ -2375,7 +2378,7 @@ and do_type_expect_ ?in_function ctx env sexp ty_expected = (type_label_exp true env loc ty_record) opath lid_sexp_list in unify_exp_types loc env ty_record (instance env ty_expected); - + (* type_label_a_list returns a list of labels sorted by lbl_pos *) (* note: check_duplicates would better be implemented in type_label_a_list directly *) @@ -3110,7 +3113,7 @@ and type_label_access env loc srecord lid = let label = Label.disambiguate lid env opath labels in (record, label, opath) -and type_label_exp create env loc ty_expected +and type_label_exp create env loc ty_expected (lid, label, sarg) = (* Here also ty_expected may be at generic_level *) begin_def (); @@ -3228,7 +3231,7 @@ and type_argument env sarg ty_expected' ty_expected = (Warnings.Without_principality "eliminated optional argument"); if is_nonexpansive texp then func texp else (* let-expand to have side effects *) - let let_pat, let_var = var_pair "let" texp.exp_type in + let let_pat, let_var = var_pair "arg" texp.exp_type in re { texp with exp_type = ty_fun; exp_desc = Texp_let (Nonrecursive, [let_pat, texp], func let_var) } end @@ -4141,8 +4144,8 @@ let report_error env ppf = function fprintf ppf "The record field %a is not mutable" longident lid | Wrong_name (kind, p, lid) -> fprintf ppf "The %s type %a has no %s %a" kind path p - (if kind = "record" then "field" else "constructor") - longident lid; + (if kind = "record" then "field" else "constructor") + longident lid; if kind = "record" then Label.spellcheck ppf env p lid else Constructor.spellcheck ppf env p lid | Name_type_mismatch (kind, lid, tp, tpl) -> diff --git a/typing/typecore.mli b/typing/typecore.mli index 7a85655d81..453b26bb89 100644 --- a/typing/typecore.mli +++ b/typing/typecore.mli @@ -83,7 +83,7 @@ type error = | Label_missing of Ident.t list | Label_not_mutable of Longident.t | Wrong_name of string * Path.t * Longident.t - | Name_type_mismatch of + | Name_type_mismatch of string * Longident.t * (Path.t * Path.t) * (Path.t * Path.t) list | Incomplete_format of string | Bad_conversion of string * int * char @@ -132,7 +132,9 @@ val report_error: Env.t -> formatter -> error -> unit (* Forward declaration, to be filled in by Typemod.type_module *) val type_module: (Env.t -> Parsetree.module_expr -> Typedtree.module_expr) ref (* Forward declaration, to be filled in by Typemod.type_open *) -val type_open: (override_flag -> Env.t -> Location.t -> Longident.t loc -> Path.t * Env.t) ref +val type_open: + (override_flag -> Env.t -> Location.t -> Longident.t loc -> Path.t * Env.t) + ref (* Forward declaration, to be filled in by Typeclass.class_structure *) val type_object: (Env.t -> Location.t -> Parsetree.class_structure -> diff --git a/typing/typedecl.ml b/typing/typedecl.ml index 0e5d20c5a8..d70c4804d7 100644 --- a/typing/typedecl.ml +++ b/typing/typedecl.ml @@ -492,6 +492,7 @@ let get_variance ty visited = let compute_variance env visited vari ty = let rec compute_variance_rec vari ty = + (* Format.eprintf "%a: %x@." Printtyp.type_expr ty (Obj.magic vari); *) let ty = Ctype.repr ty in let vari' = get_variance ty visited in if Variance.subset vari vari' then () else @@ -525,7 +526,7 @@ let compute_variance env visited vari ty = if strict then compute_variance_rec full ty else let p1 = inter v vari and n1 = inter v (conjugate vari) in - let v1 = + let v1 = union (inter covariant (union p1 (conjugate p1))) (inter (conjugate covariant) (union n1 (conjugate n1))) and weak = @@ -617,7 +618,7 @@ let compute_variance_type env check (required, loc) decl tyl = params required; (* Check propagation from constrained parameters *) let args = Btype.newgenty (Ttuple params) in - let fvl = if check then Ctype.free_variables args else [] in + let fvl = Ctype.free_variables args in let fvl = List.filter (fun v -> not (List.memq v params)) fvl in (* If there are no extra variables there is nothing to do *) if fvl = [] then () else @@ -645,7 +646,7 @@ let compute_variance_type env check (required, loc) decl tyl = Btype.backtrack snap; let (c1,n1) = get_upper v1 and (c2,n2,_,i2) = get_lower v2 in if c1 && not c2 || n1 && not n2 then - if List.memq ty fvl then + if List.memq ty fvl then let code = if not i2 then -2 else if c2 || n2 then -1 else -3 in raise (Error (loc, Bad_variance (code, (c1,n1,false), (c2,n2,false)))) else @@ -693,7 +694,8 @@ let compute_variance_gadt env check (required, loc as rloc) decl | Some ret_type -> match Ctype.repr ret_type with | {desc=Tconstr (path, tyl, _)} -> - let tyl = List.map (Ctype.expand_head env) tyl in + (* let tyl = List.map (Ctype.expand_head env) tyl in *) + let tyl = List.map Ctype.repr tyl in let fvl = List.map Ctype.free_variables tyl in let _ = List.fold_left2 @@ -1067,11 +1069,16 @@ let transl_with_constraint env id row_path orig_decl sdecl = let cty = transl_simple_type env no_row sty in Some cty, Some cty.ctyp_type in + let priv = + if sdecl.ptype_private = Private then Private else + if arity_ok && orig_decl.type_kind <> Type_abstract + then orig_decl.type_private else sdecl.ptype_private + in let decl = { type_params = params; type_arity = List.length params; type_kind = if arity_ok then orig_decl.type_kind else Type_abstract; - type_private = sdecl.ptype_private; + type_private = priv; type_manifest = man; type_variance = []; type_newtype_level = None; diff --git a/typing/typedtree.ml b/typing/typedtree.ml index 6c1d2285b2..f21e318478 100644 --- a/typing/typedtree.ml +++ b/typing/typedtree.ml @@ -237,7 +237,7 @@ and structure_item_desc = | Tstr_open of override_flag * Path.t * Longident.t loc | Tstr_class of (class_declaration * string list * virtual_flag) list | Tstr_class_type of (Ident.t * string loc * class_type_declaration) list - | Tstr_include of module_expr * Ident.t list + | Tstr_include of module_expr * Types.signature (*> JOCAML *) | Tstr_def of joinautomaton list | Tstr_exn_global of Path.t * Longident.t loc diff --git a/typing/typedtree.mli b/typing/typedtree.mli index 8ec1e94610..e70bfa257c 100644 --- a/typing/typedtree.mli +++ b/typing/typedtree.mli @@ -236,7 +236,7 @@ and structure_item_desc = | Tstr_open of override_flag * Path.t * Longident.t loc | Tstr_class of (class_declaration * string list * virtual_flag) list | Tstr_class_type of (Ident.t * string loc * class_type_declaration) list - | Tstr_include of module_expr * Ident.t list + | Tstr_include of module_expr * Types.signature (*> JOCAML *) | Tstr_def of joinautomaton list | Tstr_exn_global of Path.t * Longident.t loc diff --git a/typing/typedtreeMap.ml b/typing/typedtreeMap.ml index 93a1bfc4c8..d75924a6a9 100644 --- a/typing/typedtreeMap.ml +++ b/typing/typedtreeMap.ml @@ -169,8 +169,8 @@ module MakeMap(Map : MapArgument) = struct (id, name, Map.leave_class_infos { ct with ci_expr = ci_expr}) ) list in Tstr_class_type list - | Tstr_include (mexpr, idents) -> - Tstr_include (map_module_expr mexpr, idents) + | Tstr_include (mexpr, sg) -> + Tstr_include (map_module_expr mexpr, sg) (*>JOCAML*) | Tstr_def d -> Tstr_def (map_joinautomata d) @@ -453,7 +453,7 @@ module MakeMap(Map : MapArgument) = struct | Tsig_modtype (id, name, mdecl) -> Tsig_modtype (id, name, map_modtype_declaration mdecl) | Tsig_open _ -> item.sig_desc - | Tsig_include (mty, lid) -> Tsig_include (map_module_type mty, lid) + | Tsig_include (mty, sg) -> Tsig_include (map_module_type mty, sg) | Tsig_class list -> Tsig_class (List.map map_class_description list) | Tsig_class_type list -> Tsig_class_type (List.map map_class_type_declaration list) diff --git a/typing/typemod.ml b/typing/typemod.ml index b28adebb4a..cfc5eaadc3 100644 --- a/typing/typemod.ml +++ b/typing/typemod.ml @@ -378,17 +378,27 @@ let check_sig_item type_names module_names modtype_names loc = function check "module type" loc modtype_names (Ident.name id) | _ -> () -let rec remove_values ids = function +let rec remove_duplicates val_ids exn_ids = function [] -> [] | Sig_value (id, _) :: rem - when List.exists (Ident.equal id) ids -> remove_values ids rem - | f :: rem -> f :: remove_values ids rem + when List.exists (Ident.equal id) val_ids -> + remove_duplicates val_ids exn_ids rem + | Sig_exception(id, _) :: rem + when List.exists (Ident.equal id) exn_ids -> + remove_duplicates val_ids exn_ids rem + | f :: rem -> f :: remove_duplicates val_ids exn_ids rem let rec get_values = function [] -> [] | Sig_value (id, _) :: rem -> id :: get_values rem | f :: rem -> get_values rem +let rec get_exceptions = function + [] -> [] + | Sig_exception (id, _) :: rem -> id :: get_exceptions rem + | f :: rem -> get_exceptions rem + + (* Check and translate a module type expression *) let transl_modtype_longident loc env lid = @@ -483,7 +493,8 @@ and transl_signature env sg = let (id, newenv) = Env.enter_exception name.txt arg.exn_exn env in let (trem, rem, final_env) = transl_sig newenv srem in mksig (Tsig_exception (id, name, arg)) env loc :: trem, - Sig_exception(id, arg.exn_exn) :: rem, + (if List.exists (Ident.equal id) (get_exceptions rem) then rem + else Sig_exception(id, arg.exn_exn) :: rem), final_env | Psig_module(name, smty) -> check "module" item.psig_loc module_names name.txt; @@ -531,7 +542,8 @@ and transl_signature env sg = let newenv = Env.add_signature sg env in let (trem, rem, final_env) = transl_sig newenv srem in mksig (Tsig_include (tmty, sg)) env loc :: trem, - remove_values (get_values rem) sg @ rem, final_env + remove_duplicates (get_values rem) (get_exceptions rem) sg @ rem, + final_env | Psig_class cl -> List.iter (fun {pci_name = name} -> @@ -678,20 +690,6 @@ let check_nongen_scheme env str = let check_nongen_schemes env str = List.iter (check_nongen_scheme env) str -(* Extract the list of "value" identifiers bound by a signature. - "Value" identifiers are identifiers for signature components that - correspond to a run-time value: values, exceptions, modules, classes. - Note: manifest primitives do not correspond to a run-time value! *) - -let rec bound_value_identifiers = function - [] -> [] - | Sig_value(id, {val_kind = Val_reg}) :: rem -> - id :: bound_value_identifiers rem - | Sig_exception(id, decl) :: rem -> id :: bound_value_identifiers rem - | Sig_module(id, mty, _) :: rem -> id :: bound_value_identifiers rem - | Sig_class(id, decl, _) :: rem -> id :: bound_value_identifiers rem - | _ :: rem -> bound_value_identifiers rem - (*> JOCAML *) (* Channels appear as regular values in signatures *) let make_sig_channel_value env id = @@ -958,7 +956,8 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope = let loc = pstr.pstr_loc in let mk desc = let str = { str_desc = desc; str_loc = loc; str_env = env } in - Cmt_format.set_saved_types (Cmt_format.Partial_structure_item str :: previous_saved_types); + Cmt_format.set_saved_types (Cmt_format.Partial_structure_item str + :: previous_saved_types); str in match pstr.pstr_desc with @@ -1145,7 +1144,7 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope = List.iter (check_sig_item type_names module_names modtype_names loc) sg; let new_env = Env.add_signature sg env in - let item = mk (Tstr_include (modl, bound_value_identifiers sg)) in + let item = mk (Tstr_include (modl, sg)) in let (str_rem, sig_rem, final_env) = type_struct new_env srem in (item :: str_rem, sg @ sig_rem, @@ -1185,7 +1184,8 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope = (Cmt_format.Partial_structure str :: previous_saved_types); str, sg, final_env -let type_toplevel_phrase env s = type_structure ~toplevel:true false None env s Location.none +let type_toplevel_phrase env s = + type_structure ~toplevel:true false None env s Location.none let type_module = type_module true false None let type_structure = type_structure false None diff --git a/typing/typemod.mli b/typing/typemod.mli index d34bde86ac..cda00694ab 100644 --- a/typing/typemod.mli +++ b/typing/typemod.mli @@ -39,8 +39,6 @@ val save_signature : string -> Typedtree.signature -> string -> string -> val package_units: string list -> string -> string -> Typedtree.module_coercion -val bound_value_identifiers : Types.signature_item list -> Ident.t list - type error = Cannot_apply of module_type | Not_included of Includemod.error list diff --git a/typing/types.ml b/typing/types.ml index 74c6e22569..1d3c875c7d 100644 --- a/typing/types.ml +++ b/typing/types.ml @@ -179,7 +179,7 @@ module Variance = struct let conjugate v = swap May_pos May_neg (swap Pos Neg v) let get_upper v = (mem May_pos v, mem May_neg v) let get_lower v = (mem Pos v, mem Neg v, mem Inv v, mem Inj v) -end +end (* Type definitions *) diff --git a/typing/types.mli b/typing/types.mli index bc4841d3e4..3d3e433cd8 100644 --- a/typing/types.mli +++ b/typing/types.mli @@ -166,7 +166,7 @@ module Variance : sig val conjugate : t -> t (* exchange positive and negative *) val get_upper : t -> bool * bool (* may_pos, may_neg *) val get_lower : t -> bool * bool * bool * bool (* pos, neg, inv, inj *) -end +end (* Type definitions *) diff --git a/utils/clflags.ml b/utils/clflags.ml index 63630ae93d..03849e5030 100644 --- a/utils/clflags.ml +++ b/utils/clflags.ml @@ -107,4 +107,3 @@ let shared = ref false (* -shared *) let dlcode = ref true (* not -nodynlink *) let runtime_variant = ref "";; (* -runtime-variant *) - diff --git a/utils/config.mlbuild b/utils/config.mlbuild index e624f835ce..5f2b9cef51 100644 --- a/utils/config.mlbuild +++ b/utils/config.mlbuild @@ -47,7 +47,8 @@ let standard_runtime = if windows then "ocamlrun" else C.bindir^"/ocamlrun" let ccomp_type = C.ccomptype -let bytecomp_c_compiler = sf "%s %s %s" C.bytecc C.bytecccompopts C.sharedcccompopts +let bytecomp_c_compiler = + sf "%s %s %s" C.bytecc C.bytecccompopts C.sharedcccompopts let bytecomp_c_libraries = C.bytecclibs let native_c_compiler = sf "%s %s" C.nativecc C.nativecccompopts let native_c_libraries = C.nativecclibs @@ -60,15 +61,15 @@ let mkexe = C.mkexe let mkmaindll = C.mkmaindll let exec_magic_number = "Caml1999X008" -and cmi_magic_number = "Caml1999I014" +and cmi_magic_number = "Caml1999I015" and cmo_magic_number = "Caml1999O007" and cma_magic_number = "Caml1999A008" and cmx_magic_number = "Caml1999Y011" and cmxa_magic_number = "Caml1999Z010" -and ast_impl_magic_number = "Caml1999M015" -and ast_intf_magic_number = "Caml1999N014" +and ast_impl_magic_number = "Caml1999M016" +and ast_intf_magic_number = "Caml1999N015" and cmxs_magic_number = "Caml2007D001" -and cmt_magic_number = "Caml2012T001" +and cmt_magic_number = "Caml2012T002" let load_path = ref ([] : string list) diff --git a/utils/config.mli b/utils/config.mli index 269efe4176..2f8e89d490 100644 --- a/utils/config.mli +++ b/utils/config.mli @@ -38,8 +38,8 @@ val native_c_compiler: string val native_c_libraries: string (* The C libraries to link with native-code programs *) val native_pack_linker: string - (* The linker to use for packaging (ocamlopt -pack) and for partial links - (ocamlopt -output-obj). *) + (* The linker to use for packaging (ocamlopt -pack) and for partial + links (ocamlopt -output-obj). *) val mkdll: string (* The linker command line to build dynamic libraries. *) val mkexe: string diff --git a/utils/config.mlp b/utils/config.mlp index 249b8dd342..987aec795a 100644 --- a/utils/config.mlp +++ b/utils/config.mlp @@ -53,15 +53,15 @@ let mkexe = "%%MKEXE%%" let mkmaindll = "%%MKMAINDLL%%" let exec_magic_number = "Caml1999X008" -and cmi_magic_number = "Caml1999I014" +and cmi_magic_number = "Caml1999I015" and cmo_magic_number = "Caml1999O007" and cma_magic_number = "Caml1999A008" and cmx_magic_number = "Caml1999Y011" and cmxa_magic_number = "Caml1999Z010" -and ast_impl_magic_number = "Caml1999M015" -and ast_intf_magic_number = "Caml1999N014" +and ast_impl_magic_number = "Caml1999M016" +and ast_intf_magic_number = "Caml1999N015" and cmxs_magic_number = "Caml2007D001" -and cmt_magic_number = "Caml2012T001" +and cmt_magic_number = "Caml2012T002" let load_path = ref ([] : string list) diff --git a/utils/warnings.ml b/utils/warnings.ml index df4cdc94b9..b543f0852b 100644 --- a/utils/warnings.ml +++ b/utils/warnings.ml @@ -62,6 +62,8 @@ type t = | Disambiguated_name of string (* 42 *) | Nonoptional_label of string (* 43 *) | Open_shadow_identifier of string * string (* 44 *) + | Open_shadow_label_constructor of string * string (* 45 *) + | Bad_env_variable of string * string (* 46 *) ;; (* If you remove a warning, leave a hole in the numbering. NEVER change @@ -115,9 +117,11 @@ let number = function | Disambiguated_name _ -> 42 | Nonoptional_label _ -> 43 | Open_shadow_identifier _ -> 44 + | Open_shadow_label_constructor _ -> 45 + | Bad_env_variable _ -> 46 ;; -let last_warning_number = 44 +let last_warning_number = 46 (* Must be the max number returned by the [number] function. *) let letter = function @@ -212,7 +216,7 @@ let parse_opt flags s = let parse_options errflag s = parse_opt (if errflag then error else active) s;; (* 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";; +let defaults_w = "+a-4-6-7-9-27-29-32..39-41..42-44-45";; let defaults_warn_error = "-a";; let () = parse_options false defaults_w;; @@ -338,6 +342,12 @@ let message = function Printf.sprintf "this open statement shadows the %s identifier %s (which is later used)" kind s + | Open_shadow_label_constructor (kind, s) -> + Printf.sprintf + "this open statement shadows the %s %s (which is later used)" + kind s + | Bad_env_variable (var, s) -> + Printf.sprintf "illegal environment variable %s : %s" var s ;; let nerrors = ref 0;; @@ -428,6 +438,7 @@ let descriptions = 42, "Disambiguated constructor or label name."; 43, "Nonoptional label applied as optional."; 44, "Open statement shadows an already defined identifier."; + 45, "Open statement shadows an already defined label or constructor."; ] ;; diff --git a/utils/warnings.mli b/utils/warnings.mli index 9843195faa..fa480653dc 100644 --- a/utils/warnings.mli +++ b/utils/warnings.mli @@ -57,6 +57,8 @@ type t = | Disambiguated_name of string (* 42 *) | Nonoptional_label of string (* 43 *) | Open_shadow_identifier of string * string (* 44 *) + | Open_shadow_label_constructor of string * string (* 45 *) + | Bad_env_variable of string * string ;; val parse_options : bool -> string -> unit;; |