From: Stephane Glondu Date: Sat, 21 Jul 2012 12:36:39 +0000 (+0200) Subject: Imported Upstream version 4.00.0~rc1 X-Git-Tag: archive/raspbian/4.08.1-4+rpi1~3^2~63^2~12 X-Git-Url: https://dgit.raspbian.org/?a=commitdiff_plain;h=b96287d44838b8338a0aee56481546bf9374354f;p=ocaml.git Imported Upstream version 4.00.0~rc1 --- diff --git a/Changes b/Changes index 8f708f96..3f876233 100644 --- a/Changes +++ b/Changes @@ -36,13 +36,14 @@ Native-code compiler: savings of 28%. . Added support for position-independent code, natdynlink, profiling and exception backtraces. -- In -g mode, generation of CFI information and a few filename/line - number debugging annotations, enabling in particular precise stack - backtraces with the gdb debugger. Currently supported for x86 32-bits - and 64-bits only. (PR#5487) +- Generation of CFI information, and filename/line number debugging (with -g) + annotations, enabling in particular precise stack backtraces with + the gdb debugger. Currently supported for x86 32-bits and 64-bits only. + (PR#5487) - New tool: ocamloptp, the equivalent of ocamlcp for the native-code compiler. OCamldoc: +- PR#5645: ocamldoc doesn't handle module/type substitution in signatures - PR#5544: improve HTML output (less formatting in html code) - PR#5522: allow refering to record fields and variant constructors - fix PR#5419 (error message in french) @@ -64,7 +65,7 @@ Standard library: . Fixed behavior of generic hash function w.r.t. -0.0 and NaN (PR#5222) . Added optional "random" parameter to Hashtbl.create to randomize collision patterns and improve security (PR#5572, CVE-2012-0839) - . Added "randomize" function and "R" parameter to OCAMLRUNPARAMS + . Added "randomize" function and "R" parameter to OCAMLRUNPARAM to turn randomization on by default (PR#5572, CVE-2012-0839) . Added new functorial interface "MakeSeeded" to support randomization with user-provided seeded hash functions. @@ -75,7 +76,7 @@ Standard library: - Random: . More random initialization (Random.self_init()), using /dev/urandom when available (e.g. Linux, FreeBSD, MacOS X, Solaris) - . Faster implementation of Random.float + * Faster implementation of Random.float (changes the generated sequences) - Scanf: new function "unescaped" (PR#3888) - Set and Map: more efficient implementation of "filter" and "partition" - String: new function "map" (PR#3888) @@ -104,7 +105,7 @@ Bug Fixes: - PR#3571: in Bigarrays, call msync() before unmapping to commit changes - PR#4292: various documentation problems - PR#4511, PR#4838: local modules remove polymorphism -- PR#4549: Filename.dirname is not handling multiple / on Unix +* PR#4549: Filename.dirname is not handling multiple / on Unix - PR#4688: (Windows) special floating-point values aren't converted to strings correctly - PR#4697: Unix.putenv leaks memory on failure @@ -115,24 +116,31 @@ Bug Fixes: - PR#4892: Array.set could raise "out of bounds" before evaluating 3rd arg - PR#4937: camlp4 incorrectly handles optional arguments if 'option' is redefined -- PR#5024: camlp4r now handles underscores in irrefutable patern matching of - records +- PR#5024: camlp4r now handles underscores in irrefutable pattern matching of + records - PR#5064, PR#5485: try to ensure that 4K words of stack are available before calling into C functions, raising a Stack_overflow exception otherwise. This reduces (but does not eliminate) the risk of segmentation faults due to stack overflow in C code +- PR#5073: wrong location for 'Unbound record field label' error - PR#5084: sub-sub-module building fails for native code compilation - PR#5120: fix the output function of Camlp4.Debug.formatter +- PR#5131: compilation of custom runtime with g++ generates lots of warnings +- PR#5137: caml-types-explore does not work - PR#5159: better documentation of type Lexing.position - PR#5171: Map.join does more comparisons than needed - PR#5176: emacs mode: stack overflow in regexp matcher - PR#5179: port OCaml to mingw-w64 - PR#5211: updated Genlex documentation to state that camlp4 is mandatory for 'parser' keyword and associated notation +- PR#5214: ocamlfind plugin invokes 'cut' utility +- PR#5218: use $(MAKE) instead of "make" in Makefiles - PR#5224: confusing error message in non-regular type definition - PR#5231: camlp4: fix parsing of <:str_item< type t = $x$ >> +- PR#5233: finaliser on weak array gives dangling pointers (crash) - PR#5238, PR#5277: Sys_error when getting error location - PR#5261, PR#5497: Ocaml source-code examples are not "copy-paste-able" +* PR#5279: executable name is not initialized properly in caml_startup_code - PR#5290: added hash functions for channels, nats, mutexes, conditions - PR#5295: OS threads: problem with caml_c_thread_unregister() - PR#5301: camlp4r and exception equal to another one with parameters @@ -141,6 +149,8 @@ Bug Fixes: - PR#5309: Queue.add is not thread/signal safe - PR#5310: Ratio.create_ratio/create_normalized_ratio have misleading names - PR#5311: better message for warning 23 +* PR#5312: command-line arguments @reponsefile auto-expansion feature + removed from the Windows OCaml runtime, to avoid conflicts with "-w @..." - PR#5313: ocamlopt -g misses optimizations - PR#5316: objinfo now shows ccopts/ccobjs/force_link when applicable - PR#5318: segfault on stack overflow when reading marshaled data @@ -200,6 +210,7 @@ Bug Fixes: and -docflags switches - PR#5543: in Bigarray.map_file, try to avoid using lseek() when growing file - PR#5538: combining -i and -annot in ocamlc +- PR#5648: (probably fixed) test failures in tests/lib-threads - PR#5551: repeated calls to find_in_path degrade performance - PR#5552: Mac OS X: unrecognized gcc option "-no-cpp-precomp" - PR#5555: add Hashtbl.reset to resize the bucket table to its initial size @@ -210,6 +221,7 @@ Bug Fixes: - PR#5585: typo: "explicitely" - PR#5587: documentation: "allows to" is not correct English - PR#5593: remove C file when -output-obj fails +- PR#5597: register names for instrtrace primitives in embedded bytecode - PR#5598: add backslash-space support in strings in ocamllex - PR#5603: wrong .file debug info generated by ocamlopt -g - PR#5604: fix permissions of files created by ocamlbuild itself @@ -218,9 +230,24 @@ Bug Fixes: - PR#5616: move ocamlbuild documentation to the reference manual - PR#5619: Uncaught CType.Unify exception in the compiler - PR#5620: invalid printing of type manifest (camlp4 revised syntax) +- PR#5637: invalid printing of anonymous type parameters (camlp4 revised syntax) +- PR#5643: issues with .cfi and .loc directives generated by ocamlopt -g +- PR#5644: Stream.count broken when used with Sapp or Slazy nodes +- PR#5647: Cannot use install_printer in debugger +- PR#5651: printer for abstract data type (camlp4 revised syntax) +- PR#5654: self pattern variable location tweak +- PR#5655: ocamlbuild doesn't pass cflags when building C stubs +- PR#5657: wrong error location for abbreviated record fields +- PR#5659: ocamlmklib -L option breaks with MSVC +- PR#5661: fixes for the test suite +- PR#5668: Camlp4 produces invalid syntax for "let _ = ..." +- PR#5671: initialization of compare_ext field in caml_final_custom_operations() +- PR#5677: do not use "value" as identifier (genprintval.ml) +- PR#5687: dynlink broken when used from "output-obj" main program (bytecode) - problem with printing of string literals in camlp4 (reported on caml-list) - emacs mode: colorization of comments and strings now works correctly - problem with forall and method (reported on caml-list on 2011-07-26) +- crash when using OCAMLRUNPARAM=a=X with invalid X (reported in private) Feature wishes: - PR#352: new option "-stdin" to make ocaml read stdin as a script @@ -240,9 +267,11 @@ Feature wishes: - PR#5215: marshalling of dynlinked closure - PR#5236: new '%revapply' primitive with the semantics 'revapply x f = f x', and '%apply' with semantics 'apply f x = f x'. +- PR#5255: natdynlink detection on powerpc, hurd, sparc - PR#5295: OS threads: problem with caml_c_thread_unregister() - PR#5297: compiler now checks existence of builtin primitives - PR#5329: (Windows) more efficient Unix.select if all fd's are sockets +- PR#5357: warning for useless open statements - PR#5358: first class modules don't allow "with type" declarations for types in sub-modules - PR#5385: configure: emit a warning when MACOSX_DEPLOYMENT_TARGET is set @@ -253,7 +282,6 @@ Feature wishes: - PR#5420: Unix.openfile share mode (Windows) - PR#5421: Unix: do not leak fds in various open_proc* functions - PR#5434: implement Unix.times in win32unix (partially) -- PR#5437: warning for useless open statements - PR#5438: new warnings for unused declarations - PR#5439: upgrade config.guess and config.sub - PR#5445 and others: better printing of types with user-provided names @@ -269,7 +297,12 @@ Feature wishes: - PR#5555: add function Hashtbl.reset to resize the bucket table to its initial size. - PR#5586: increase UNIX_BUFFER_SIZE to 64KiB +- PR#5597: register names for instrtrace primitives in embedded bytecode - PR#5599: Add warn() tag in ocamlbuild to control -w compiler switch +- PR#5628: add #remove_directory and Topdirs.remove_directory to remove + a directory from the load path +- PR#5636: in system threads library, issue with linking of pthread_atfork +- PR#5666: C includes don't provide a revision number - ocamldebug: ability to inspect values that contain code pointers - ocamldebug: new 'environment' directive to set environment variables for debuggee diff --git a/INSTALL b/INSTALL index 0e709192..98dfd31d 100644 --- a/INSTALL +++ b/INSTALL @@ -169,6 +169,9 @@ Examples: For Sun Solaris with the "acc" compiler: ./configure -cc "acc -fast" -libs "-lucb" + For Sun Solaris on Sparc 64bit, to compile natively (32bit only) + ./configure -cc "gcc -m32" -as "as -32" -aspp "gcc -m32 -c" + For AIX 4.3 with the IBM compiler xlc: ./configure -cc "xlc_r -D_AIX43 -Wl,-bexpall,-brtl -qmaxmem=8192" diff --git a/Makefile b/Makefile index 70919395..7a5978f4 100644 --- a/Makefile +++ b/Makefile @@ -10,7 +10,7 @@ # # ######################################################################### -# $Id: Makefile 12511 2012-05-30 13:29:48Z lefessan $ +# $Id: Makefile 12692 2012-07-10 15:20:34Z doligez $ # The main Makefile @@ -387,7 +387,7 @@ ocamlnat: ocamlopt otherlibs/dynlink/dynlink.cmxa $(NATTOPOBJS:.cmo=.cmx) toplevel/opttoploop.cmx: otherlibs/dynlink/dynlink.cmxa otherlibs/dynlink/dynlink.cmxa: otherlibs/dynlink/natdynlink.ml - cd otherlibs/dynlink && make allopt + cd otherlibs/dynlink && $(MAKE) allopt # The configuration file @@ -761,7 +761,7 @@ clean:: package-macosx: sudo rm -rf package-macosx/root - make PREFIX="`pwd`"/package-macosx/root install + $(MAKE) PREFIX="`pwd`"/package-macosx/root install tools/make-package-macosx sudo rm -rf package-macosx/root diff --git a/Makefile.nt b/Makefile.nt index 3a064b9f..671cf20a 100644 --- a/Makefile.nt +++ b/Makefile.nt @@ -10,7 +10,7 @@ # # ######################################################################### -# $Id: Makefile.nt 12511 2012-05-30 13:29:48Z lefessan $ +# $Id: Makefile.nt 12692 2012-07-10 15:20:34Z doligez $ # The main Makefile @@ -246,9 +246,9 @@ installoptopt: cp ocamlc.opt $(BINDIR)/ocamlc.opt$(EXE) cp ocamlopt.opt $(BINDIR)/ocamlopt.opt$(EXE) cp lex/ocamllex.opt $(BINDIR)/ocamllex.opt$(EXE) - cp compilerlibs/ocamlcommon.cmxa compilerlibs/ocamlcommon.a \ - compilerlibs/ocamlbytecomp.cmxa compilerlibs/ocamlbytecomp.a \ - compilerlibs/ocamloptcomp.cmxa compilerlibs/ocamloptcomp.a \ + cp compilerlibs/ocamlcommon.cmxa compilerlibs/ocamlcommon.$(A) \ + compilerlibs/ocamlbytecomp.cmxa compilerlibs/ocamlbytecomp.$(A) \ + compilerlibs/ocamloptcomp.cmxa compilerlibs/ocamloptcomp.$(A) \ $(COMPLIBDIR) clean:: partialclean @@ -319,7 +319,7 @@ ocamlnat: ocamlopt otherlibs/dynlink/dynlink.cmxa $(NATTOPOBJS:.cmo=.cmx) toplevel/opttoploop.cmx: otherlibs/dynlink/dynlink.cmxa otherlibs/dynlink/dynlink.cmxa: otherlibs/dynlink/natdynlink.ml - cd otherlibs/dynlink && make allopt + cd otherlibs/dynlink && $(MAKE) allopt # The configuration file @@ -386,14 +386,14 @@ beforedepend:: parsing/lexer.ml compilerlibs/ocamlcommon.cmxa: $(COMMON:.cmo=.cmx) $(CAMLOPT) -a -o $@ $(COMMON:.cmo=.cmx) partialclean:: - rm -f compilerlibs/ocamlcommon.cmxa compilerlibs/ocamlcommon.a + rm -f compilerlibs/ocamlcommon.cmxa compilerlibs/ocamlcommon.$(A) # The bytecode compiler compiled with the native-code compiler compilerlibs/ocamlbytecomp.cmxa: $(BYTECOMP:.cmo=.cmx) $(CAMLOPT) -a -o $@ $(BYTECOMP:.cmo=.cmx) partialclean:: - rm -f compilerlibs/ocamlbytecomp.cmxa compilerlibs/ocamlbytecomp.a + rm -f compilerlibs/ocamlbytecomp.cmxa compilerlibs/ocamlbytecomp.$(A) ocamlc.opt: compilerlibs/ocamlcommon.cmxa compilerlibs/ocamlbytecomp.cmxa $(BYTESTART:.cmo=.cmx) $(CAMLOPT) $(LINKFLAGS) -ccopt "$(BYTECCLINKOPTS)" -o ocamlc.opt \ @@ -411,7 +411,7 @@ partialclean:: compilerlibs/ocamloptcomp.cmxa: $(ASMCOMP:.cmo=.cmx) $(CAMLOPT) -a -o $@ $(ASMCOMP:.cmo=.cmx) partialclean:: - rm -f compilerlibs/ocamloptcomp.cmxa compilerlibs/ocamloptcomp.a + rm -f compilerlibs/ocamloptcomp.cmxa compilerlibs/ocamloptcomp.$(A) ocamlopt.opt: compilerlibs/ocamlcommon.cmxa compilerlibs/ocamloptcomp.cmxa $(OPTSTART:.cmo=.cmx) $(CAMLOPT) $(LINKFLAGS) -o ocamlopt.opt \ diff --git a/README.win32 b/README.win32 index 54d42ef9..067cc623 100644 --- a/README.win32 +++ b/README.win32 @@ -91,8 +91,7 @@ THIRD-PARTY SOFTWARE: Can be downloaded from http://alain.frisch.fr/flexdll.html [3] TCL/TK version 8.5. Windows binaries are available as part of the - ActiveTCL distribution at http://www.activestate.com/products/ActiveTcl/ - + ActiveTCL distribution at http://www.activestate.com/activetcl/downloads RECOMPILATION FROM THE SOURCES: @@ -186,7 +185,7 @@ contributed his changes to the OCaml project. REQUIREMENTS: -This port runs under MS Windows Vista, XP, and 2000. +This port runs under MS Windows Seven, Vista, XP, and 2000. The base bytecode system (ocamlc, ocaml, ocamllex, ocamlyacc, ...) runs without any additional tools. @@ -202,10 +201,14 @@ the Setup tool from Cygwin): mingw64-i686-binutils mingw64-i686-gcc + mingw64-i686-gcc-core mingw64-i686-runtime -NOTE: +NOTES: + + - Do not use the Cygwin version of flexdll for this port. + - There is another 32-bit gcc compiler, from the MinGW.org project, packaged in Cygwin under the name mingw-gcc. It is not currently supported by flexdll and OCaml. @@ -223,7 +226,7 @@ NOTE: The LablTk GUI requires Tcl/Tk 8.5. Windows binaries are available as part of the ActiveTCL distribution at -http://www.activestate.com/products/ActiveTcl/ + http://www.activestate.com/activetcl/downloads Note that you will need to install the 32-bit version of ActiveTCL, even if you are on a 64-bit version of Windows. @@ -246,23 +249,26 @@ environment variable. E.g. if Tcl/Tk was installed in C:\tcl, add RECOMPILATION FROM THE SOURCES: You will need the following software components to perform the recompilation: -- Windows NT, 2000, XP, or Vista. -- Cygwin: http://sourceware.cygnus.com/cygwin/ - Install at least the following packages: +- Windows NT, 2000, XP, Vista, or Seven. +- Cygwin: http://cygwin.com/ + Install at least the following packages (and their dependencies, as + computed by Cygwin's setup.exe): mingw64-i686-binutils mingw64-i686-gcc + mingw64-i686-gcc-core mingw64-i686-runtime diffutils make ncurses -- TCL/TK version 8.5 (see above). -- The flexdll tool (see above). +- Tcl/Tk version 8.5 (see above). +- The flexdll tool (see above). Do not forget to add the flexdll directory + to your PATH The standalone mingw toolchain from the MinGW-w64 project (http://mingw-w64.sourceforge.net/) is not supported. Please use the version packaged in Cygwin instead. -Start a Cygwin shell and unpack the source distribution +Start a new Cygwin shell and unpack the source distribution (ocaml-X.YY.Z.tar.gz) with "tar xzf". Change to the top-level directory of the OCaml distribution. Then, do @@ -273,7 +279,7 @@ directory of the OCaml distribution. Then, do Then, edit config/Makefile as needed, following the comments in this file. Normally, the only variables that need to be changed are PREFIX where to install everything - TK_ROOT where TCL/TK was installed + TK_ROOT where Tcl/Tk was installed Finally, use "make -f Makefile.nt" to build the system, e.g. @@ -317,14 +323,17 @@ the OCaml packages). Alternatively, recompile from the source distribution. RECOMPILATION FROM THE SOURCES: +Before starting, make sure that the gcc version installed by cygwin +is not 4.5.3 (it has a bug that affects OCaml). If needed, use cygwin's +setup.exe to downgrade to 4.3.4. + You will need to recompile (and install) flexdll from source with Cygwin's C compiler because the official binary version of flexdll doesn't handle Cygwin's symbolic links and sometimes fails to launch the C compiler. In order to recompile flexdll, you first need to configure, compile, -and install OCaml without flexdll support (by following the instructions -in file INSTALL, except the "make opt.opt" part), then modify the +and install OCaml without flexdll support, then modify the flexdll Makefile to change line 51 from: LINKFLAGS = -ccopt "-link version_res.o" to: @@ -333,7 +342,7 @@ to: Then "make CHAINS=cygwin" and add the flexdll directory to your PATH. Make sure to add it before "/usr/bin" or you will get cygwin's flexlink. -Then, OCaml's source directory, type: +Then, in OCaml's source directory, type: make clean make distclean and follow the instructions for Unix machines given in the file INSTALL. @@ -341,11 +350,14 @@ and follow the instructions for Unix machines given in the file INSTALL. NOTES: -The libraries available in this port are "num", "str", "threads", -"unix" and "labltk". "graph" is not available. -The replay debugger is fully supported. -When upgrading from 3.12.0 to 3.12.1, you will need to remove -/usr/local/bin/ocamlmktop.exe before typing "make install". +- There is a problem with cygwin's port of gcc version 4.5.3. You should + use cygwin's setup program to downgrade to 4.3.4 before compiling OCaml. +- The replay debugger is fully supported. +- When upgrading from 3.12.0 to 3.12.1, you will need to remove + /usr/local/bin/ocamlmktop.exe before typing "make install". +- In order to use the "graph" and "labltk" libraries, you will need + to use Cygwin's setup.exe to install the xinit, libX11-devel, tcl, + and tcl-tk packages before compiling OCaml. ------------------------------------------------------------------------------ diff --git a/VERSION b/VERSION index 58bb2927..b9d49671 100644 --- a/VERSION +++ b/VERSION @@ -1,6 +1,6 @@ -4.00.0+beta2 +4.00.0+rc1 # The version string is the first line of this file. # It must be in the format described in stdlib/sys.mli -# $Id: VERSION 12567 2012-06-04 17:01:09Z doligez $ +# $Id: VERSION 12743 2012-07-19 14:37:16Z doligez $ diff --git a/asmcomp/amd64/emit.mlp b/asmcomp/amd64/emit.mlp index 35c7f313..47f652d0 100644 --- a/asmcomp/amd64/emit.mlp +++ b/asmcomp/amd64/emit.mlp @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: emit.mlp 12448 2012-05-12 09:49:40Z xleroy $ *) +(* $Id: emit.mlp 12664 2012-07-09 08:35:23Z lefessan $ *) (* Emission of x86-64 (AMD 64) assembly code *) @@ -396,7 +396,9 @@ let emit_instr fallthrough i = if alloc then begin ` {load_symbol_addr s}, %rax\n`; ` {emit_call "caml_c_call"}\n`; - record_frame i.live i.dbg + record_frame i.live i.dbg; + ` {load_symbol_addr "caml_young_ptr"}, %r11\n`; + ` movq (%r11), %r15\n`; end else begin ` {emit_call s}\n` end diff --git a/asmcomp/debuginfo.ml b/asmcomp/debuginfo.ml index ab0f5c04..19986f83 100644 --- a/asmcomp/debuginfo.ml +++ b/asmcomp/debuginfo.ml @@ -31,11 +31,12 @@ let none = { dinfo_char_end = 0 } +(* PR#5643: cannot use (==) because Debuginfo values are marshalled *) let is_none t = - t == none + t = none let to_string d = - if d == none + if d = none then "" else Printf.sprintf "{%s:%d,%d-%d}" d.dinfo_file d.dinfo_line d.dinfo_char_start d.dinfo_char_end diff --git a/asmcomp/debuginfo.mli b/asmcomp/debuginfo.mli index cf6179cd..ef4d55ad 100644 --- a/asmcomp/debuginfo.mli +++ b/asmcomp/debuginfo.mli @@ -12,7 +12,7 @@ type kind = Dinfo_call | Dinfo_raise -type t = { +type t = private { dinfo_kind: kind; dinfo_file: string; dinfo_line: int; diff --git a/asmcomp/emitaux.ml b/asmcomp/emitaux.ml index 1fffc65a..a0659794 100644 --- a/asmcomp/emitaux.ml +++ b/asmcomp/emitaux.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: emitaux.ml 12448 2012-05-12 09:49:40Z xleroy $ *) +(* $Id: emitaux.ml 12699 2012-07-11 15:26:15Z lefessan $ *) (* Common functions for emitting assembly code *) @@ -114,41 +114,6 @@ let emit_float32_directive directive f = let x = Int32.bits_of_float (float_of_string f) in emit_printf "\t%s\t0x%lx\n" directive x -(* Emit debug information *) - -(* This assoc list is expected to be very short *) -let file_pos_nums = - (ref [] : (string * int) list ref) - -(* Number of files *) -let file_pos_num_cnt = ref 1 - -(* Reset debug state at beginning of asm file *) -let reset_debug_info () = - file_pos_nums := []; - file_pos_num_cnt := 1 - -(* We only diplay .file if the file has not been seen before. We - display .loc for every instruction. *) -let emit_debug_info dbg = - if !Clflags.debug && not (Debuginfo.is_none dbg) then ( - let line = dbg.Debuginfo.dinfo_line in - let file_name = dbg.Debuginfo.dinfo_file in - let file_num = - try List.assoc file_name !file_pos_nums - with Not_found -> - let file_num = !file_pos_num_cnt in - incr file_pos_num_cnt; - emit_string " .file "; - emit_int file_num; emit_char ' '; - emit_string_literal file_name; emit_char '\n'; - file_pos_nums := (file_name,file_num) :: !file_pos_nums; - file_num in - emit_string " .loc "; - emit_int file_num; emit_char ' '; - emit_int line; emit_char '\n' - ) - (* Record live pointers at call points *) type frame_descr = @@ -182,13 +147,13 @@ let emit_frames a = lbl in let emit_frame fd = a.efa_label fd.fd_lbl; - a.efa_16 (if fd.fd_debuginfo == Debuginfo.none + a.efa_16 (if Debuginfo.is_none fd.fd_debuginfo then fd.fd_frame_size else fd.fd_frame_size + 1); a.efa_16 (List.length fd.fd_live_offset); List.iter a.efa_16 fd.fd_live_offset; a.efa_align Arch.size_addr; - if fd.fd_debuginfo != Debuginfo.none then begin + if not (Debuginfo.is_none fd.fd_debuginfo) then begin let d = fd.fd_debuginfo in let line = min 0xFFFFF d.dinfo_line and char_start = min 0xFF d.dinfo_char_start @@ -228,7 +193,7 @@ let is_generic_function name = (* CFI directives *) let is_cfi_enabled () = - !Clflags.debug && Config.asm_cfi_supported + Config.asm_cfi_supported let cfi_startproc () = if is_cfi_enabled () then @@ -243,4 +208,40 @@ let cfi_adjust_cfa_offset n = begin emit_string " .cfi_adjust_cfa_offset "; emit_int n; emit_string "\n"; end - + +(* Emit debug information *) + +(* This assoc list is expected to be very short *) +let file_pos_nums = + (ref [] : (string * int) list ref) + +(* Number of files *) +let file_pos_num_cnt = ref 1 + +(* Reset debug state at beginning of asm file *) +let reset_debug_info () = + file_pos_nums := []; + file_pos_num_cnt := 1 + +(* We only diplay .file if the file has not been seen before. We + display .loc for every instruction. *) +let emit_debug_info dbg = + if is_cfi_enabled () && + !Clflags.debug && not (Debuginfo.is_none dbg) then begin + let line = dbg.Debuginfo.dinfo_line in + assert (line <> 0); (* clang errors out on zero line numbers *) + let file_name = dbg.Debuginfo.dinfo_file in + let file_num = + try List.assoc file_name !file_pos_nums + with Not_found -> + let file_num = !file_pos_num_cnt in + incr file_pos_num_cnt; + emit_string " .file "; + emit_int file_num; emit_char ' '; + emit_string_literal file_name; emit_char '\n'; + file_pos_nums := (file_name,file_num) :: !file_pos_nums; + file_num in + emit_string " .loc "; + emit_int file_num; emit_char ' '; + emit_int line; emit_char '\n' + end diff --git a/asmcomp/power/arch.ml b/asmcomp/power/arch.ml index 696073e3..c940fa34 100644 --- a/asmcomp/power/arch.ml +++ b/asmcomp/power/arch.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: arch.ml 12187 2012-02-24 10:13:02Z xleroy $ *) +(* $Id: arch.ml 12583 2012-06-07 12:19:23Z xleroy $ *) (* Specific operations for the PowerPC processor *) @@ -48,7 +48,7 @@ let size_float = 8 (* Behavior of division *) -let division_crashes_on_overflow = false +let division_crashes_on_overflow = true (* Operations on addressing modes *) diff --git a/asmcomp/printlinear.ml b/asmcomp/printlinear.ml index 44a39597..e617177c 100644 --- a/asmcomp/printlinear.ml +++ b/asmcomp/printlinear.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: printlinear.ml 12179 2012-02-21 17:41:02Z xleroy $ *) +(* $Id: printlinear.ml 12610 2012-06-17 08:15:25Z xleroy $ *) (* Pretty-printing of linearized machine code *) @@ -65,7 +65,7 @@ let instr ppf i = | Lraise -> fprintf ppf "raise %a" reg i.arg.(0) end; - if i.dbg != Debuginfo.none then + if not (Debuginfo.is_none i.dbg) then fprintf ppf " %s" (Debuginfo.to_string i.dbg) let rec all_instr ppf i = diff --git a/asmrun/amd64.S b/asmrun/amd64.S index 45bddd1c..fd26e198 100644 --- a/asmrun/amd64.S +++ b/asmrun/amd64.S @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: amd64.S 12179 2012-02-21 17:41:02Z xleroy $ */ +/* $Id: amd64.S 12664 2012-07-09 08:35:23Z lefessan $ */ /* Asm part of the runtime system, AMD64 processor */ /* Must be preprocessed by cpp */ @@ -22,7 +22,7 @@ #if defined(SYS_macosx) -#define LBL(x) L##x +#define LBL(x) L##x #define G(r) _##r #define GREL(r) _##r@GOTPCREL #define GCALL(r) _##r @@ -35,8 +35,8 @@ name: #elif defined(SYS_mingw64) - -#define LBL(x) .L##x + +#define LBL(x) .L##x #define G(r) r #undef GREL #define GCALL(r) r @@ -50,7 +50,7 @@ #else -#define LBL(x) .L##x +#define LBL(x) .L##x #define G(r) r #define GREL(r) r@GOTPCREL #define GCALL(r) r@PLT @@ -74,7 +74,7 @@ #define CFI_ENDPROC #define CFI_ADJUST(n) #endif - + #if defined(__PIC__) && !defined(SYS_mingw64) /* Position-independent operations on global variables. */ @@ -119,7 +119,7 @@ popq %r11 #else - + /* Non-PIC operations on global variables. Slightly faster. */ #define STORE_VAR(srcreg,dstlabel) \ @@ -148,10 +148,10 @@ #endif -/* Save and restore all callee-save registers on stack. +/* Save and restore all callee-save registers on stack. Keep the stack 16-aligned. */ -#if defined(SYS_mingw64) +#if defined(SYS_mingw64) /* Win64 API: callee-save regs are rbx, rbp, rsi, rdi, r12-r15, xmm6-xmm15 */ @@ -219,11 +219,11 @@ popq %rbp; \ popq %rbx -#endif +#endif #ifdef SYS_mingw64 /* Calls from OCaml to C must reserve 32 bytes of extra stack space */ -# define PREPARE_FOR_C_CALL subq $32, %rsp +# define PREPARE_FOR_C_CALL subq $32, %rsp # define CLEANUP_AFTER_C_CALL addq $32, %rsp #else # define PREPARE_FOR_C_CALL @@ -389,6 +389,7 @@ LBL(caml_c_call): popq %r12 STORE_VAR(%r12, caml_last_return_address) STORE_VAR(%rsp, caml_bottom_of_stack) + pushq %r12 #ifndef SYS_mingw64 /* Touch the stack to trigger a recoverable segfault if insufficient space remains */ @@ -402,12 +403,7 @@ LBL(caml_c_call): /* Call the function (address in %rax) */ /* No need to PREPARE_FOR_C_CALL since the caller already reserved the stack space if needed (cf. amd64/proc.ml) */ - call *%rax - /* Reload alloc ptr */ - LOAD_VAR(caml_young_ptr, %r15) - /* Return to caller */ - pushq %r12 - ret + jmp *%rax /* Start the OCaml program */ diff --git a/boot/ocamlc b/boot/ocamlc index 97d88e42..3dbcbc00 100755 Binary files a/boot/ocamlc and b/boot/ocamlc differ diff --git a/boot/ocamldep b/boot/ocamldep index e54c57cd..275022b6 100755 Binary files a/boot/ocamldep and b/boot/ocamldep differ diff --git a/boot/ocamllex b/boot/ocamllex index 6ae4967c..843a9513 100755 Binary files a/boot/ocamllex and b/boot/ocamllex differ diff --git a/bytecomp/dll.ml b/bytecomp/dll.ml index 67f38819..c765cbef 100644 --- a/bytecomp/dll.ml +++ b/bytecomp/dll.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: dll.ml 11156 2011-07-27 14:17:02Z doligez $ *) +(* $Id: dll.ml 12661 2012-07-07 11:41:17Z scherer $ *) (* Handling of dynamically-linked libraries *) @@ -40,6 +40,9 @@ let names_of_opened_dlls = ref ([] : string list) let add_path dirs = search_path := dirs @ !search_path +let remove_path dirs = + search_path := List.filter (fun d -> not (List.mem d dirs)) !search_path + (* Extract the name of a DLLs from its external name (xxx.so or -lxxx) *) let extract_dll_name file = diff --git a/bytecomp/dll.mli b/bytecomp/dll.mli index 2b1dec0c..4eaecfde 100644 --- a/bytecomp/dll.mli +++ b/bytecomp/dll.mli @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: dll.mli 11156 2011-07-27 14:17:02Z doligez $ *) +(* $Id: dll.mli 12661 2012-07-07 11:41:17Z scherer $ *) (* Handling of dynamically-linked libraries *) @@ -46,6 +46,9 @@ val synchronize_primitive: int -> dll_address -> unit (* Add the given directories at the head of the search path for DLLs *) val add_path: string list -> unit +(* Remove the given directories from the search path for DLLs *) +val remove_path: string list -> unit + (* Initialization for separate compilation. Initialize the DLL search path to the directories given in the environment variable CAML_LD_LIBRARY_PATH, plus contents of ld.conf file diff --git a/bytecomp/symtable.ml b/bytecomp/symtable.ml index 872a4bbf..7ab4bfd9 100644 --- a/bytecomp/symtable.ml +++ b/bytecomp/symtable.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: symtable.ml 11306 2011-12-13 17:50:08Z frisch $ *) +(* $Id: symtable.ml 12629 2012-06-21 15:55:03Z doligez $ *) (* To assign numbers to globals and primitives *) @@ -126,7 +126,7 @@ let output_primitive_table outchan = fprintf outchan " %s,\n" prim.(i) done; fprintf outchan " (primitive) 0 };\n"; - fprintf outchan "char * caml_names_of_builtin_cprim[] = {\n"; + fprintf outchan "const char * caml_names_of_builtin_cprim[] = {\n"; for i = 0 to Array.length prim - 1 do fprintf outchan " \"%s\",\n" prim.(i) done; diff --git a/bytecomp/translcore.ml b/bytecomp/translcore.ml index a6f531e0..b515cd1a 100644 --- a/bytecomp/translcore.ml +++ b/bytecomp/translcore.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: translcore.ml 12511 2012-05-30 13:29:48Z lefessan $ *) +(* $Id: translcore.ml 12681 2012-07-10 08:33:16Z garrigue $ *) (* Translation from typed abstract syntax to lambda terms, for the core language *) @@ -484,18 +484,19 @@ let rec push_defaults loc bindings pat_expr_list partial = [pat, exp] | (pat, exp) :: _ when bindings <> [] -> let param = name_pattern "param" pat_expr_list in + let name = Ident.name param in let exp = { exp with exp_loc = loc; exp_desc = Texp_match ({exp with exp_type = pat.pat_type; exp_desc = - Texp_ident (Path.Pident param, mknoloc (Longident.Lident "param"), + Texp_ident (Path.Pident param, mknoloc (Longident.Lident name), {val_type = pat.pat_type; val_kind = Val_reg; Types.val_loc = Location.none; })}, pat_expr_list, partial) } in push_defaults loc bindings - [{pat with pat_desc = Tpat_var (param, mknoloc "param")}, exp] Total + [{pat with pat_desc = Tpat_var (param, mknoloc name)}, exp] Total | _ -> pat_expr_list @@ -833,9 +834,6 @@ and transl_exp0 e = cl_loc = e.exp_loc; cl_type = Cty_signature cty; cl_env = e.exp_env } - | Texp_poly (exp, _ ) - | Texp_newtype (_, exp) - -> transl_exp exp and transl_list expr_list = List.map transl_exp expr_list diff --git a/byterun/Makefile b/byterun/Makefile index 32cccdb0..2d1006ec 100644 --- a/byterun/Makefile +++ b/byterun/Makefile @@ -11,7 +11,7 @@ # # ######################################################################### -# $Id: Makefile 12567 2012-06-04 17:01:09Z doligez $ +# $Id: Makefile 12566 2012-06-04 16:33:59Z doligez $ include Makefile.common diff --git a/byterun/compact.c b/byterun/compact.c index c1e66994..11a2cad2 100644 --- a/byterun/compact.c +++ b/byterun/compact.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: compact.c 12524 2012-05-31 11:50:51Z doligez $ */ +/* $Id: compact.c 12621 2012-06-20 15:39:09Z doligez $ */ #include @@ -397,7 +397,7 @@ uintnat caml_percent_max; /* used in gc_ctrl.c and memory.c */ void caml_compact_heap (void) { - uintnat target_size; + uintnat target_size, live; do_compaction (); /* Compaction may fail to shrink the heap to a reasonable size @@ -416,13 +416,15 @@ void caml_compact_heap (void) /* We compute: freewords = caml_fl_cur_size (exact) heapsize = caml_heap_size (exact) - usedwords = heap_size - freewords - target_size = usedwords * (1 + caml_percent_free / 100) + live = heap_size - freewords + target_size = live * (1 + caml_percent_free / 100) + = live / 100 * (100 + caml_percent_free) + We add 1 to live/100 to make sure it isn't 0. We recompact if target_size < heap_size / 2 */ - target_size = (caml_stat_heap_size - Bsize_wsize (caml_fl_cur_size)) - * (100 + caml_percent_free) / 100; + live = caml_stat_heap_size - Bsize_wsize (caml_fl_cur_size); + target_size = (live / 100 + 1) * (100 + caml_percent_free); target_size = caml_round_heap_chunk_size (target_size); if (target_size < caml_stat_heap_size / 2){ char *chunk; diff --git a/byterun/custom.c b/byterun/custom.c index 7388602f..41813a1b 100644 --- a/byterun/custom.c +++ b/byterun/custom.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: custom.c 11156 2011-07-27 14:17:02Z doligez $ */ +/* $Id: custom.c 12658 2012-07-06 16:44:24Z xleroy $ */ #include @@ -83,6 +83,7 @@ struct custom_operations * caml_final_custom_operations(final_fun fn) ops->hash = custom_hash_default; ops->serialize = custom_serialize_default; ops->deserialize = custom_deserialize_default; + ops->compare_ext = custom_compare_ext_default; l = caml_stat_alloc(sizeof(struct custom_operations_list)); l->ops = ops; l->next = custom_ops_final_table; diff --git a/byterun/dynlink.c b/byterun/dynlink.c index 736a6d8f..5cb2ed7d 100644 --- a/byterun/dynlink.c +++ b/byterun/dynlink.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: dynlink.c 11156 2011-07-27 14:17:02Z doligez $ */ +/* $Id: dynlink.c 12677 2012-07-09 14:15:48Z doligez $ */ /* Dynamic loading of C primitives. */ @@ -184,8 +184,15 @@ void caml_build_primitive_table_builtin(void) { int i; caml_ext_table_init(&caml_prim_table, 0x180); - for (i = 0; caml_builtin_cprim[i] != 0; i++) +#ifdef DEBUG + caml_ext_table_init(&caml_prim_name_table, 0x180); +#endif + for (i = 0; caml_builtin_cprim[i] != 0; i++) { caml_ext_table_add(&caml_prim_table, (void *) caml_builtin_cprim[i]); +#ifdef DEBUG + caml_ext_table_add(&caml_prim_name_table, strdup(caml_names_of_builtin_cprim[i])); +#endif +} } #endif /* NATIVE_CODE */ diff --git a/byterun/fix_code.c b/byterun/fix_code.c index 84d46689..c3142197 100644 --- a/byterun/fix_code.c +++ b/byterun/fix_code.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: fix_code.c 12227 2012-03-13 14:44:48Z xleroy $ */ +/* $Id: fix_code.c 12715 2012-07-16 10:37:03Z frisch $ */ /* Handling of blocks of bytecode (endianness switch, threading). */ @@ -38,15 +38,8 @@ unsigned char caml_code_md5[16]; /* Read the main bytecode block from a file */ -void caml_load_code(int fd, asize_t len) -{ - int i; +void caml_init_code_fragments() { struct code_fragment * cf; - - caml_code_size = len; - caml_start_code = (code_t) caml_stat_alloc(caml_code_size); - if (read(fd, (char *) caml_start_code, caml_code_size) != caml_code_size) - caml_fatal_error("Fatal error: truncated bytecode file.\n"); /* Register the code in the table of code fragments */ cf = caml_stat_alloc(sizeof(struct code_fragment)); cf->code_start = (char *) caml_start_code; @@ -55,6 +48,17 @@ void caml_load_code(int fd, asize_t len) cf->digest_computed = 1; caml_ext_table_init(&caml_code_fragments_table, 8); caml_ext_table_add(&caml_code_fragments_table, cf); +} + +void caml_load_code(int fd, asize_t len) +{ + int i; + + caml_code_size = len; + caml_start_code = (code_t) caml_stat_alloc(caml_code_size); + if (read(fd, (char *) caml_start_code, caml_code_size) != caml_code_size) + caml_fatal_error("Fatal error: truncated bytecode file.\n"); + caml_init_code_fragments(); /* Prepare the code for execution */ #ifdef ARCH_BIG_ENDIAN caml_fixup_endianness(caml_start_code, caml_code_size); diff --git a/byterun/fix_code.h b/byterun/fix_code.h index e344018a..81124878 100644 --- a/byterun/fix_code.h +++ b/byterun/fix_code.h @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: fix_code.h 12227 2012-03-13 14:44:48Z xleroy $ */ +/* $Id: fix_code.h 12715 2012-07-16 10:37:03Z frisch $ */ /* Handling of blocks of bytecode (endianness switch, threading). */ @@ -27,6 +27,7 @@ extern code_t caml_start_code; extern asize_t caml_code_size; extern unsigned char * caml_saved_code; +void caml_init_code_fragments(); void caml_load_code (int fd, asize_t len); void caml_fixup_endianness (code_t code, asize_t len); void caml_set_instruction (code_t pos, opcode_t instr); diff --git a/byterun/freelist.c b/byterun/freelist.c index 4733a538..f84478ba 100644 --- a/byterun/freelist.c +++ b/byterun/freelist.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: freelist.c 11156 2011-07-27 14:17:02Z doligez $ */ +/* $Id: freelist.c 12708 2012-07-13 12:03:26Z doligez $ */ #define FREELIST_DEBUG 0 #if FREELIST_DEBUG @@ -532,14 +532,14 @@ void caml_set_allocation_policy (uintnat p) switch (p){ case Policy_next_fit: fl_prev = Fl_head; + policy = p; break; case Policy_first_fit: flp_size = 0; beyond = NULL; + policy = p; break; default: - Assert (0); break; } - policy = p; } diff --git a/byterun/gc_ctrl.c b/byterun/gc_ctrl.c index ece9a54d..5d6c8245 100644 --- a/byterun/gc_ctrl.c +++ b/byterun/gc_ctrl.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: gc_ctrl.c 12149 2012-02-10 16:15:24Z doligez $ */ +/* $Id: gc_ctrl.c 12708 2012-07-13 12:03:26Z doligez $ */ #include "alloc.h" #include "compact.h" @@ -356,21 +356,12 @@ static intnat norm_minsize (intnat s) return s; } -static intnat norm_policy (intnat p) -{ - if (p >= 0 && p <= 1){ - return p; - }else{ - return 1; - } -} - CAMLprim value caml_gc_set(value v) { uintnat newpf, newpm; asize_t newheapincr; asize_t newminsize; - uintnat newpolicy; + uintnat oldpolicy; caml_verb_gc = Long_val (Field (v, 3)); @@ -396,10 +387,11 @@ CAMLprim value caml_gc_set(value v) caml_gc_message (0x20, "New heap increment size: %luk bytes\n", caml_major_heap_increment/1024); } - newpolicy = norm_policy (Long_val (Field (v, 6))); - if (newpolicy != caml_allocation_policy){ - caml_gc_message (0x20, "New allocation policy: %d\n", newpolicy); - caml_set_allocation_policy (newpolicy); + oldpolicy = caml_allocation_policy; + caml_set_allocation_policy (Long_val (Field (v, 6))); + if (oldpolicy != caml_allocation_policy){ + caml_gc_message (0x20, "New allocation policy: %d\n", + caml_allocation_policy); } /* Minor heap size comes last because it will trigger a minor collection diff --git a/byterun/io.c b/byterun/io.c index d7d341f8..ca01a4fe 100644 --- a/byterun/io.c +++ b/byterun/io.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: io.c 12149 2012-02-10 16:15:24Z doligez $ */ +/* $Id: io.c 12641 2012-06-25 12:02:16Z lefessan $ */ /* Buffered input/output. */ @@ -279,6 +279,11 @@ CAMLexport int caml_do_read(int fd, char *p, unsigned int n) do { caml_enter_blocking_section(); retcode = read(fd, p, n); +#if defined(_WIN32) + if (retcode == -1 && errno == ENOMEM && n > 16384){ + retcode = read(fd, p, 16384); + } +#endif caml_leave_blocking_section(); } while (retcode == -1 && errno == EINTR); if (retcode == -1) caml_sys_io_error(NO_ARG); diff --git a/byterun/major_gc.c b/byterun/major_gc.c index 772c3fc4..ab8f7459 100644 --- a/byterun/major_gc.c +++ b/byterun/major_gc.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: major_gc.c 11156 2011-07-27 14:17:02Z doligez $ */ +/* $Id: major_gc.c 12625 2012-06-21 13:43:03Z doligez $ */ #include @@ -233,7 +233,11 @@ static void mark_slice (intnat work) weak_prev = &Field (cur, 0); work -= Whsize_hd (hd); }else{ - /* Subphase_weak1 is done. Start removing dead weak arrays. */ + /* Subphase_weak1 is done. + Handle finalised values and start removing dead weak arrays. */ + gray_vals_cur = gray_vals_ptr; + caml_final_update (); + gray_vals_ptr = gray_vals_cur; caml_gc_subphase = Subphase_weak2; weak_prev = &caml_weak_list_head; } @@ -254,10 +258,7 @@ static void mark_slice (intnat work) } work -= 1; }else{ - /* Subphase_weak2 is done. Handle finalised values. */ - gray_vals_cur = gray_vals_ptr; - caml_final_update (); - gray_vals_ptr = gray_vals_cur; + /* Subphase_weak2 is done. Go to Subphase_final. */ caml_gc_subphase = Subphase_final; } } diff --git a/byterun/startup.c b/byterun/startup.c index 5f35e877..b774016d 100644 --- a/byterun/startup.c +++ b/byterun/startup.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: startup.c 12215 2012-03-10 01:46:37Z meyer $ */ +/* $Id: startup.c 12715 2012-07-16 10:37:03Z frisch $ */ /* Start-up code */ @@ -443,6 +443,10 @@ CAMLexport void caml_startup_code( { value res; char* cds_file; + char * exe_name; +#ifdef __linux__ + static char proc_self_exe[256]; +#endif caml_init_ieee_floats(); caml_init_custom_operations(); @@ -455,6 +459,11 @@ CAMLexport void caml_startup_code( strcpy(caml_cds_file, cds_file); } parse_camlrunparam(); + exe_name = argv[0]; +#ifdef __linux__ + if (caml_executable_name(proc_self_exe, sizeof(proc_self_exe)) == 0) + exe_name = proc_self_exe; +#endif caml_external_raise = NULL; /* Initialize the abstract machine */ caml_init_gc (minor_heap_init, heap_size_init, heap_chunk_init, @@ -468,6 +477,7 @@ CAMLexport void caml_startup_code( /* Load the code */ caml_start_code = code; caml_code_size = code_size; + caml_init_code_fragments(); if (caml_debugger_in_use) { int len, i; len = code_size / sizeof(opcode_t); @@ -489,7 +499,7 @@ CAMLexport void caml_startup_code( caml_section_table_size = section_table_size; /* Initialize system libraries */ caml_init_exceptions(); - caml_sys_init("", argv); + caml_sys_init(exe_name, argv); /* Execute the program */ caml_debugger(PROGRAM_START); res = caml_interprete(caml_start_code, caml_code_size); diff --git a/byterun/win32.c b/byterun/win32.c index cc0f046b..f8ba9c98 100644 --- a/byterun/win32.c +++ b/byterun/win32.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: win32.c 12242 2012-03-14 15:27:58Z xleroy $ */ +/* $Id: win32.c 12686 2012-07-10 11:34:39Z scherer $ */ /* Win32-specific stuff */ @@ -205,7 +205,6 @@ static int argvsize; static void store_argument(char * arg); static void expand_argument(char * arg); static void expand_pattern(char * arg); -static void expand_diversion(char * filename); static void out_of_memory(void) { @@ -227,10 +226,6 @@ static void expand_argument(char * arg) { char * p; - if (arg[0] == '@') { - expand_diversion(arg + 1); - return; - } for (p = arg; *p != 0; p++) { if (*p == '*' || *p == '?') { expand_pattern(arg); @@ -265,62 +260,6 @@ static void expand_pattern(char * pat) _findclose(handle); } -static void expand_diversion(char * filename) -{ - struct _stat stat; - int fd; - char * buf, * endbuf, * p, * q, * s; - int inquote; - - if (_stat(filename, &stat) == -1 || - (fd = _open(filename, O_RDONLY | O_BINARY, 0)) == -1) { - fprintf(stderr, "Cannot open file %s\n", filename); - exit(2); - } - buf = (char *) malloc(stat.st_size + 1); - if (buf == NULL) out_of_memory(); - _read(fd, buf, stat.st_size); - endbuf = buf + stat.st_size; - _close(fd); - for (p = buf; p < endbuf; /*nothing*/) { - /* Skip leading blanks */ - while (p < endbuf && isspace(*p)) p++; - if (p >= endbuf) break; - s = p; - /* Skip to end of argument, taking quotes into account */ - q = s; - inquote = 0; - while (p < endbuf) { - if (! inquote) { - if (isspace(*p)) break; - if (*p == '"') { inquote = 1; p++; continue; } - *q++ = *p++; - } else { - switch (*p) { - case '"': - inquote = 0; p++; continue; - case '\\': - if (p + 4 <= endbuf && strncmp(p, "\\\\\\\"", 4) == 0) { - p += 4; *q++ = '\\'; *q++ = '"'; continue; - } - if (p + 3 <= endbuf && strncmp(p, "\\\\\"", 3) == 0) { - p += 3; *q++ = '\\'; inquote = 0; continue; - } - if (p + 2 <= endbuf && p[1] == '"') { - p += 2; *q++ = '"'; continue; - } - /* fallthrough */ - default: - *q++ = *p++; - } - } - } - /* Delimit argument and expand it */ - *q++ = 0; - expand_argument(s); - p++; - } -} CAMLexport void caml_expand_command_line(int * argcp, char *** argvp) { diff --git a/camlp4/Camlp4/Printers/OCaml.ml b/camlp4/Camlp4/Printers/OCaml.ml index c1b5f1d9..338655f0 100644 --- a/camlp4/Camlp4/Printers/OCaml.ml +++ b/camlp4/Camlp4/Printers/OCaml.ml @@ -106,8 +106,8 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct "Cannot print %S this identifier does not respect OCaml lexing rules (%s)" str (Lexer.Error.to_string exn)) ]; - value ocaml_char x = - match x with [ "'" -> "\\'" | c -> c ]; + (* This is to be sure character literals are always escaped. *) + value ocaml_char x = Char.escaped (Struct.Token.Eval.char x); value rec get_expr_args a al = match a with @@ -301,16 +301,19 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct | <:binding< $b1$ and $b2$ >> -> do { o#binding f b1; pp f o#andsep; o#binding f b2 } | <:binding< $p$ = $e$ >> -> - let (pl, e) = + let (pl, e') = match p with [ <:patt< ($_$ : $_$) >> -> ([], e) | _ -> expr_fun_args e ] in - match (p, e) with - [ (<:patt< $lid:_$ >>, <:expr< ($e$ : $t$) >>) -> + match (p, e') with + [ (<:patt< $lid:_$ >>, <:expr< ($e'$ : $t$) >>) -> pp f "%a :@ %a =@ %a" - (list o#fun_binding "@ ") [`patt p::pl] o#ctyp t o#expr e - | _ -> pp f "%a @[<0>%a=@]@ %a" o#simple_patt - p (list' o#fun_binding "" "@ ") pl o#expr e ] + (list o#fun_binding "@ ") [`patt p::pl] o#ctyp t o#expr e' + | (<:patt< $lid:_$ >>, _) -> + pp f "%a @[<0>%a=@]@ %a" o#simple_patt + p (list' o#fun_binding "" "@ ") pl o#expr e' + | _ -> + pp f "%a =@ %a" o#simple_patt p o#expr e ] | <:binding< $anti:s$ >> -> o#anti f s ]; method record_binding f bi = @@ -557,7 +560,7 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct | <:expr< $int64:s$ >> -> o#numeric f s "L" | <:expr< $int32:s$ >> -> o#numeric f s "l" | <:expr< $flo:s$ >> -> o#numeric f s "" - | <:expr< $chr:s$ >> -> pp f "'%s'" s + | <:expr< $chr:s$ >> -> pp f "'%s'" (ocaml_char s) | <:expr< $id:i$ >> -> o#var_ident f i | <:expr< { $b$ } >> -> pp f "@[@[{%a@]@ }@]" o#record_binding b @@ -667,7 +670,7 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct | <:patt< $int32:s$ >> -> o#numeric f s "l" | <:patt< $int:s$ >> -> o#numeric f s "" | <:patt< $flo:s$ >> -> o#numeric f s "" - | <:patt< $chr:s$ >> -> pp f "'%s'" s + | <:patt< $chr:s$ >> -> pp f "'%s'" (ocaml_char s) | <:patt< ~ $s$ >> -> pp f "~%s" s | <:patt< ` $uid:s$ >> -> pp f "`%a" o#var s | <:patt< # $i$ >> -> pp f "@[<2>#%a@]" o#ident i diff --git a/camlp4/Camlp4Filters/Camlp4MetaGenerator.ml b/camlp4/Camlp4Filters/Camlp4MetaGenerator.ml index b716d5af..af338a2a 100644 --- a/camlp4/Camlp4Filters/Camlp4MetaGenerator.ml +++ b/camlp4/Camlp4Filters/Camlp4MetaGenerator.ml @@ -161,10 +161,10 @@ value filter st = let bi = mk_meta m in <:module_expr< struct - value meta_string _loc s = $m.str$ _loc s; + value meta_string _loc s = $m.str$ _loc (safe_string_escaped s); value meta_int _loc s = $m.int$ _loc s; value meta_float _loc s = $m.flo$ _loc s; - value meta_char _loc s = $m.chr$ _loc s; + value meta_char _loc s = $m.chr$ _loc (String.escaped s); value meta_bool _loc = fun [ False -> $m_uid m "False"$ diff --git a/camlp4/Camlp4Top/Rprint.ml b/camlp4/Camlp4Top/Rprint.ml index d913efcc..0a177824 100644 --- a/camlp4/Camlp4Top/Rprint.ml +++ b/camlp4/Camlp4Top/Rprint.ml @@ -301,7 +301,9 @@ and print_ty_label ppf lab = ; value type_parameter ppf (ty, (co, cn)) = - fprintf ppf "%s'%s" (if not cn then "+" else if not co then "-" else "") + fprintf ppf "%s%s%s" + (if not cn then "+" else if not co then "-" else "") + (if ty = "_" then "" else "'") ty ; @@ -451,8 +453,13 @@ and print_out_type_decl kwd ppf (name, args, ty, priv, constraints) = print_kind ty2 | ty -> print_kind ppf ty ] in - fprintf ppf "@[<2>@[@[%s %t@] =%a@]%a@]" kwd type_defined - print_types ty print_constraints constraints + match ty with + [ Otyp_abstract -> + fprintf ppf "@[<2>@[@[%s %t@]@]%a@]" kwd type_defined + print_constraints constraints + | _ -> + fprintf ppf "@[<2>@[@[%s %t@] =%a@]%a@]" kwd type_defined + print_types ty print_constraints constraints ] ; (* Phrases *) diff --git a/camlp4/boot/Camlp4.ml b/camlp4/boot/Camlp4.ml index 4030702a..4d79a539 100644 --- a/camlp4/boot/Camlp4.ml +++ b/camlp4/boot/Camlp4.ml @@ -3531,7 +3531,7 @@ module Struct = let skip_opt_linefeed (__strm : _ Stream.t) = match Stream.peek __strm with - | Some '\010' -> (Stream.junk __strm; ()) + | Some '\n' -> (Stream.junk __strm; ()) | _ -> () let chr c = @@ -3541,8 +3541,8 @@ module Struct = let rec backslash (__strm : _ Stream.t) = match Stream.peek __strm with - | Some '\010' -> (Stream.junk __strm; '\010') - | Some '\013' -> (Stream.junk __strm; '\013') + | Some '\n' -> (Stream.junk __strm; '\n') + | Some '\r' -> (Stream.junk __strm; '\r') | Some 'n' -> (Stream.junk __strm; '\n') | Some 'r' -> (Stream.junk __strm; '\r') | Some 't' -> (Stream.junk __strm; '\t') @@ -3581,8 +3581,8 @@ module Struct = let rec backslash_in_string strict store (__strm : _ Stream.t) = match Stream.peek __strm with - | Some '\010' -> (Stream.junk __strm; skip_indent __strm) - | Some '\013' -> + | Some '\n' -> (Stream.junk __strm; skip_indent __strm) + | Some '\r' -> (Stream.junk __strm; let s = __strm in (skip_opt_linefeed s; skip_indent s)) | _ -> @@ -7418,13 +7418,15 @@ module Struct = module Expr = struct - let meta_string _loc s = Ast.ExStr (_loc, s) + let meta_string _loc s = + Ast.ExStr (_loc, (safe_string_escaped s)) let meta_int _loc s = Ast.ExInt (_loc, s) let meta_float _loc s = Ast.ExFlo (_loc, s) - let meta_char _loc s = Ast.ExChr (_loc, s) + let meta_char _loc s = + Ast.ExChr (_loc, (String.escaped s)) let meta_bool _loc = function @@ -9747,13 +9749,15 @@ module Struct = module Patt = struct - let meta_string _loc s = Ast.PaStr (_loc, s) + let meta_string _loc s = + Ast.PaStr (_loc, (safe_string_escaped s)) let meta_int _loc s = Ast.PaInt (_loc, s) let meta_float _loc s = Ast.PaFlo (_loc, s) - let meta_char _loc s = Ast.PaChr (_loc, s) + let meta_char _loc s = + Ast.PaChr (_loc, (String.escaped s)) let meta_bool _loc = function @@ -18955,7 +18959,7 @@ module Printers = "Cannot print %S this identifier does not respect OCaml lexing rules (%s)" str (Lexer.Error.to_string exn)) - let ocaml_char x = match x with | "'" -> "\\'" | c -> c + let ocaml_char x = Char.escaped (Struct.Token.Eval.char x) let rec get_expr_args a al = match a with @@ -19484,7 +19488,7 @@ module Printers = | Ast.ExInt64 (_, s) -> o#numeric f s "L" | Ast.ExInt32 (_, s) -> o#numeric f s "l" | Ast.ExFlo (_, s) -> o#numeric f s "" - | Ast.ExChr (_, s) -> pp f "'%s'" s + | Ast.ExChr (_, s) -> pp f "'%s'" (ocaml_char s) | Ast.ExId (_, i) -> o#var_ident f i | Ast.ExRec (_, b, (Ast.ExNil _)) -> pp f "@[@[{%a@]@ }@]" o#record_binding b @@ -19629,7 +19633,7 @@ module Printers = | Ast.PaInt32 (_, s) -> o#numeric f s "l" | Ast.PaInt (_, s) -> o#numeric f s "" | Ast.PaFlo (_, s) -> o#numeric f s "" - | Ast.PaChr (_, s) -> pp f "'%s'" s + | Ast.PaChr (_, s) -> pp f "'%s'" (ocaml_char s) | Ast.PaLab (_, s, (Ast.PaNil _)) -> pp f "~%s" s | Ast.PaVrn (_, s) -> pp f "`%a" o#var s | Ast.PaTyp (_, i) -> pp f "@[<2>#%a@]" o#ident i @@ -20487,6 +20491,8 @@ module Printers = else ()) | Ast.TyCol (_, t1, (Ast.TyMut (_, t2))) -> pp f "@[%a :@ mutable %a@]" o#ctyp t1 o#ctyp t2 + | Ast.TyMan (_, t1, t2) -> + pp f "@[<2>%a ==@ %a@]" o#simple_ctyp t1 o#ctyp t2 | t -> super#ctyp f t method simple_ctyp = fun f t -> diff --git a/camlp4/boot/Camlp4Ast.ml b/camlp4/boot/Camlp4Ast.ml index fb49d01b..0b9a3de0 100644 --- a/camlp4/boot/Camlp4Ast.ml +++ b/camlp4/boot/Camlp4Ast.ml @@ -471,10 +471,11 @@ module Make (Loc : Sig.Loc) : Sig.Camlp4Ast with module Loc = Loc = value meta_loc = meta_loc_expr; module Expr = struct - value meta_string _loc s = Ast.ExStr _loc s; + value meta_string _loc s = + Ast.ExStr _loc (safe_string_escaped s); value meta_int _loc s = Ast.ExInt _loc s; value meta_float _loc s = Ast.ExFlo _loc s; - value meta_char _loc s = Ast.ExChr _loc s; + value meta_char _loc s = Ast.ExChr _loc (String.escaped s); value meta_bool _loc = fun [ False -> Ast.ExId _loc (Ast.IdUid _loc "False") @@ -2577,10 +2578,11 @@ module Make (Loc : Sig.Loc) : Sig.Camlp4Ast with module Loc = Loc = value meta_loc = meta_loc_patt; module Patt = struct - value meta_string _loc s = Ast.PaStr _loc s; + value meta_string _loc s = + Ast.PaStr _loc (safe_string_escaped s); value meta_int _loc s = Ast.PaInt _loc s; value meta_float _loc s = Ast.PaFlo _loc s; - value meta_char _loc s = Ast.PaChr _loc s; + value meta_char _loc s = Ast.PaChr _loc (String.escaped s); value meta_bool _loc = fun [ False -> Ast.PaId _loc (Ast.IdUid _loc "False") diff --git a/camlp4/boot/camlp4boot.ml b/camlp4/boot/camlp4boot.ml index a434eea4..9f7a6d7b 100644 --- a/camlp4/boot/camlp4boot.ml +++ b/camlp4/boot/camlp4boot.ml @@ -3033,8 +3033,16 @@ New syntax:\ [ (None, (Some Camlp4.Sig.Grammar.RightA), [ ([ Gram.Snterm (Gram.Entry.obj - (labeled_ipatt : - 'labeled_ipatt Gram.Entry.t)); + (cvalue_binding : + 'cvalue_binding Gram.Entry.t)) ], + (Gram.Action.mk + (fun (bi : 'cvalue_binding) (_loc : Gram.Loc.t) + -> (bi : 'fun_binding)))); + ([ Gram.Stry + (Gram.Snterm + (Gram.Entry.obj + (labeled_ipatt : + 'labeled_ipatt Gram.Entry.t))); Gram.Sself ], (Gram.Action.mk (fun (e : 'fun_binding) (p : 'labeled_ipatt) @@ -3042,14 +3050,6 @@ New syntax:\ (Ast.ExFun (_loc, (Ast.McArr (_loc, p, (Ast.ExNil _loc), e))) : 'fun_binding)))); - ([ Gram.Stry - (Gram.Snterm - (Gram.Entry.obj - (cvalue_binding : - 'cvalue_binding Gram.Entry.t))) ], - (Gram.Action.mk - (fun (bi : 'cvalue_binding) (_loc : Gram.Loc.t) - -> (bi : 'fun_binding)))); ([ Gram.Stry (Gram.srules fun_binding [ ([ Gram.Skeyword "("; Gram.Skeyword "type" ], diff --git a/config/auto-aux/cfi.S b/config/auto-aux/cfi.S index e055423a..acd052df 100644 --- a/config/auto-aux/cfi.S +++ b/config/auto-aux/cfi.S @@ -1,3 +1,6 @@ -.cfi_startproc -.cfi_adjust_cfa_offset 8 -.cfi_endproc +camlPervasives__loop_1128: + .file 1 "pervasives.ml" + .loc 1 193 + .cfi_startproc + .cfi_adjust_cfa_offset 8 + .cfi_endproc diff --git a/config/auto-aux/tryassemble b/config/auto-aux/tryassemble index feffbed2..7cd5582c 100644 --- a/config/auto-aux/tryassemble +++ b/config/auto-aux/tryassemble @@ -5,3 +5,13 @@ $aspp -o tst $* || exit 100 else $aspp -o tst $* 2> /dev/null || exit 100 fi + +# test as also (if differs) +if test "$aspp" != "$as"; then +if test "$verbose" = yes; then +echo "tryassemble: $as -o tst $*" >&2 +$as -o tst $* || exit 100 +else +$as -o tst $* 2> /dev/null || exit 100 +fi +fi diff --git a/configure b/configure index 72f42408..e08bbce3 100755 --- a/configure +++ b/configure @@ -13,7 +13,7 @@ # # ######################################################################### -# $Id: configure 12567 2012-06-04 17:01:09Z doligez $ +# $Id: configure 12645 2012-06-26 15:33:50Z doligez $ configure_options="$*" prefix=/usr/local @@ -629,6 +629,7 @@ if test $withsharedlibs = "yes"; then case "$host" in *-*-cygwin*) natdynlink=true;; i[3456]86-*-linux*) natdynlink=true;; + i[3456]86-*-gnu*) natdynlink=true;; x86_64-*-linux*) natdynlink=true;; i[3456]86-*-darwin[89].*) natdynlink=true;; i[3456]86-*-darwin*) @@ -636,8 +637,8 @@ if test $withsharedlibs = "yes"; then natdynlink=true fi;; x86_64-*-darwin*) natdynlink=true;; - powerpc64-*-linux*) natdynlink=true;; - sparc-*-linux*) natdynlink=true;; + powerpc*-*-linux*) natdynlink=true;; + sparc*-*-linux*) natdynlink=true;; i686-*-kfreebsd*) natdynlink=true;; x86_64-*-kfreebsd*) natdynlink=true;; i[345]86-*-freebsd*) natdynlink=true;; @@ -1556,11 +1557,14 @@ fi asm_cfi_supported=false -export aspp +export as aspp if sh ./tryassemble cfi.S; then echo "#define ASM_CFI_SUPPORTED" >> m.h asm_cfi_supported=true + echo "Assembler supports CFI" +else + echo "Assembler does not support CFI" fi # Final twiddling of compiler options to work around known bugs diff --git a/debugger/envaux.mli b/debugger/envaux.mli index 836a37c6..14cbe2db 100644 --- a/debugger/envaux.mli +++ b/debugger/envaux.mli @@ -11,12 +11,13 @@ (* *) (***********************************************************************) -(* $Id: envaux.mli 11156 2011-07-27 14:17:02Z doligez $ *) +(* $Id: envaux.mli 12700 2012-07-11 17:23:37Z lefessan $ *) open Format (* Convert environment summaries to environments *) +val env_from_summary : Env.summary -> Subst.t -> Env.t val env_of_event: Instruct.debug_event option -> Env.t (* Empty the environment caches. To be called when load_path changes. *) diff --git a/debugger/loadprinter.ml b/debugger/loadprinter.ml index e3998fd6..44c0108a 100644 --- a/debugger/loadprinter.ml +++ b/debugger/loadprinter.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: loadprinter.ml 11284 2011-11-24 09:02:48Z garrigue $ *) +(* $Id: loadprinter.ml 12673 2012-07-09 12:40:51Z xclerc $ *) (* Loading and installation of user-defined printer functions *) @@ -95,6 +95,15 @@ let rec eval_path = function (* Install, remove a printer (as in toplevel/topdirs) *) +(* since 4.00, "topdirs.cmi" is not in the same directory as the standard + libray, so we load it beforehand as it cannot be found in the search path. *) +let () = + let compiler_libs = + Filename.concat Config.standard_library "compiler-libs" in + let topdirs = + Filename.concat compiler_libs "topdirs.cmi" in + ignore (Env.read_signature "Topdirs" topdirs) + let match_printer_type desc typename = let (printer_type, _) = try diff --git a/debugger/printval.ml b/debugger/printval.ml index 20f2be7d..ed9cf6ff 100644 --- a/debugger/printval.ml +++ b/debugger/printval.ml @@ -11,7 +11,7 @@ (* *) (***********************************************************************) -(* $Id: printval.ml 11156 2011-07-27 14:17:02Z doligez $ *) +(* $Id: printval.ml 12689 2012-07-10 14:54:19Z doligez $ *) (* To print values *) @@ -47,7 +47,7 @@ let check_depth ppf depth obj ty = module EvalPath = struct - type value = Debugcom.Remote_value.t + type valu = Debugcom.Remote_value.t exception Error let rec eval_path = function Pident id -> diff --git a/emacs/caml-types.el b/emacs/caml-types.el index 04e22373..4b9556c4 100644 --- a/emacs/caml-types.el +++ b/emacs/caml-types.el @@ -10,7 +10,7 @@ ;(* *) ;(***********************************************************************) -;(* $Id: caml-types.el 12149 2012-02-10 16:15:24Z doligez $ *) +;(* $Id: caml-types.el 12695 2012-07-10 17:49:46Z doligez $ *) ; An emacs-lisp complement to the "-annot" option of ocamlc and ocamlopt. @@ -594,7 +594,7 @@ The function uses two overlays. . One overlay delimits the largest region whose all subnodes are well-typed. . Another overlay delimits the current node under the mouse (whose type - annotation is beeing displayed). + annotation is being displayed). " (interactive "e") (set-buffer (window-buffer (caml-event-window event))) @@ -686,30 +686,30 @@ The function uses two overlays. target-pos (vector target-file target-line target-bol cnum)) (save-excursion - (setq node (caml-types-find-location "type" - target-pos () target-tree)) + (setq node (caml-types-find-location target-pos "type" () + target-tree)) (set-buffer caml-types-buffer) (erase-buffer) (cond - (node - (setq Left - (caml-types-get-pos target-buf (elt node 0)) - Right - (caml-types-get-pos target-buf (elt node 1))) - (move-overlay - caml-types-expr-ovl Left Right target-buf) - (setq limits - (caml-types-find-interval target-buf - target-pos node) - type (elt node 2)) - ) - (t + ((null node) (delete-overlay caml-types-expr-ovl) (setq type "*no type information*") (setq limits (caml-types-find-interval - target-buf target-pos target-tree)) + target-buf target-pos target-tree))) + (t + (let ((left + (caml-types-get-pos target-buf (elt node 0))) + (right + (caml-types-get-pos target-buf (elt node 1)))) + (move-overlay + caml-types-expr-ovl left right target-buf) + (setq limits + (caml-types-find-interval target-buf + target-pos node) + type (cdr (assoc "type" (elt node 2)))) )) + ) (setq mes (format "type: %s" type)) (insert type) )) diff --git a/ocamlbuild/findlib.ml b/ocamlbuild/findlib.ml index 873adbab..b5ef8781 100644 --- a/ocamlbuild/findlib.ml +++ b/ocamlbuild/findlib.ml @@ -112,8 +112,24 @@ let rec query name = | Lexers.Error s -> error (Cannot_parse_query (name, s)) +let split_nl s = + let x = ref [] in + let rec go s = + let pos = String.index s '\n' in + x := (String.before s pos)::!x; + go (String.after s (pos + 1)) + in + try + go s + with Not_found -> !x + +let before_space s = + try + String.before s (String.index s ' ') + with Not_found -> s + let list () = - run_and_parse Lexers.blank_sep_strings "%s list | cut -d' ' -f1" ocamlfind + List.map before_space (split_nl & run_and_read "%s list" ocamlfind) (* The closure algorithm is easy because the dependencies are already closed and sorted for each package. We only have to make the union. We could also diff --git a/ocamlbuild/ocaml_specific.ml b/ocamlbuild/ocaml_specific.ml index f996f48e..e23a0e99 100644 --- a/ocamlbuild/ocaml_specific.ml +++ b/ocamlbuild/ocaml_specific.ml @@ -382,10 +382,18 @@ flag ["ocaml"; "compile"] begin atomize !Options.ocaml_cflags end;; +flag ["c"; "compile"] begin + atomize !Options.ocaml_cflags +end;; + flag ["ocaml"; "link"] begin atomize !Options.ocaml_lflags end;; +flag ["c"; "link"] begin + atomize !Options.ocaml_lflags +end;; + flag ["ocaml"; "ocamlyacc"] (atomize !Options.ocaml_yaccflags);; flag ["ocaml"; "menhir"] (atomize !Options.ocaml_yaccflags);; flag ["ocaml"; "doc"] (atomize !Options.ocaml_docflags);; diff --git a/ocamldoc/Makefile b/ocamldoc/Makefile index b9dd6900..74c82d3f 100644 --- a/ocamldoc/Makefile +++ b/ocamldoc/Makefile @@ -9,7 +9,7 @@ #(* *) #(***********************************************************************) -# $Id: Makefile 12511 2012-05-30 13:29:48Z lefessan $ +# $Id: Makefile 12707 2012-07-13 11:23:13Z doligez $ include ../config/Makefile @@ -50,7 +50,9 @@ ODOC_TEST=odoc_test.cmo GENERATORS_CMOS= \ generators/odoc_todo.cmo \ generators/odoc_literate.cmo -GENERATORS_CMXS=$(GENERATORS_CMOS:.cmo=.cmxs) +GENERATORS_CMXS_TMP1=$(GENERATORS_CMOS:.cmo=.cmxs) +GENERATORS_CMXS_TMP2=$(NATDYNLINK:false=) +GENERATORS_CMXS=$(GENERATORS_CMXS_TMP2:true=$(GENERATORS_CMXS_TMP1)) # Compilation @@ -207,7 +209,7 @@ libopt: $(OCAMLDOC_LIBCMXA) $(OCAMLDOC_LIBCMI) generatorsopt: $(GENERATORS_CMXS) debug: - make OCAMLPP="" + $(MAKE) OCAMLPP="" $(OCAMLDOC): $(EXECMOFILES) $(OCAMLC) -o $@ -linkall unix.cma str.cma dynlink.cma $(LINKFLAGS) $(OCAMLCMOFILES) $(EXECMOFILES) @@ -215,9 +217,9 @@ $(OCAMLDOC_OPT): $(EXECMXFILES) $(OCAMLOPT) -o $@ -linkall unix.cmxa str.cmxa dynlink.cmxa $(LINKFLAGS) $(OCAMLCMXFILES) $(EXECMXFILES) $(OCAMLDOC_LIBCMA): $(LIBCMOFILES) - $(OCAMLC) -a -o $@ $(LINKFLAGS) $(OCAMLCMOFILES) $(LIBCMOFILES) + $(OCAMLC) -a -o $@ $(LINKFLAGS) $(OCAMLSRCDIR)/tools/depend.cmo $(LIBCMOFILES) $(OCAMLDOC_LIBCMXA): $(LIBCMXFILES) - $(OCAMLOPT) -a -o $@ $(LINKFLAGS) $(OCAMLCMXFILES) $(LIBCMXFILES) + $(OCAMLOPT) -a -o $@ $(LINKFLAGS) $(OCAMLSRCDIR)/tools/depend.cmx $(LIBCMXFILES) manpages: stdlib_man/Pervasives.3o diff --git a/ocamldoc/Makefile.nt b/ocamldoc/Makefile.nt index 8133f3ae..ad44bf8f 100644 --- a/ocamldoc/Makefile.nt +++ b/ocamldoc/Makefile.nt @@ -9,7 +9,7 @@ #(* *) #(***********************************************************************) -# $Id: Makefile.nt 12553 2012-06-04 12:39:11Z protzenk $ +# $Id: Makefile.nt 12692 2012-07-10 15:20:34Z doligez $ include ../config/Makefile @@ -187,7 +187,7 @@ opt.opt: exeopt libopt exeopt: $(OCAMLDOC_OPT) libopt: $(OCAMLDOC_LIBCMXA) $(OCAMLDOC_LIBCMI) debug: - make OCAMLPP="" + $(MAKE) OCAMLPP="" $(OCAMLDOC): $(EXECMOFILES) $(OCAMLC) -o $@ -linkall unix.cma str.cma dynlink.cma $(LINKFLAGS) $(OCAMLCMOFILES) $(EXECMOFILES) diff --git a/ocamldoc/odoc_name.ml b/ocamldoc/odoc_name.ml index 04a6808a..e937a00b 100644 --- a/ocamldoc/odoc_name.ml +++ b/ocamldoc/odoc_name.ml @@ -9,7 +9,7 @@ (* *) (***********************************************************************) -(* $Id: odoc_name.ml 10643 2010-08-02 14:37:22Z doligez $ *) +(* $Id: odoc_name.ml 12622 2012-06-21 05:46:28Z guesdon $ *) (** Representation of element names. *) @@ -215,3 +215,9 @@ let to_path n = | Some p -> p let from_longident = Odoc_misc.string_of_longident + +module Set = Set.Make (struct + type z = t + type t = z + let compare = String.compare +end) diff --git a/ocamldoc/odoc_name.mli b/ocamldoc/odoc_name.mli index 5b968657..8f21e53b 100644 --- a/ocamldoc/odoc_name.mli +++ b/ocamldoc/odoc_name.mli @@ -9,7 +9,7 @@ (* *) (***********************************************************************) -(* $Id: odoc_name.mli 10643 2010-08-02 14:37:22Z doligez $ *) +(* $Id: odoc_name.mli 12622 2012-06-21 05:46:28Z guesdon $ *) (** Representation of element names. *) @@ -67,3 +67,6 @@ val to_path : t -> Path.t (** Get a name from a [Longident.t].*) val from_longident : Longident.t -> t + +(** Set of Name.t *) +module Set : Set.S with type elt = t diff --git a/ocamldoc/odoc_sig.ml b/ocamldoc/odoc_sig.ml index a0eed49e..28772530 100644 --- a/ocamldoc/odoc_sig.ml +++ b/ocamldoc/odoc_sig.ml @@ -9,7 +9,7 @@ (* *) (***********************************************************************) -(* $Id: odoc_sig.ml 12511 2012-05-30 13:29:48Z lefessan $ *) +(* $Id: odoc_sig.ml 12622 2012-06-21 05:46:28Z guesdon $ *) (** Analysis of interface files. *) @@ -257,6 +257,38 @@ module Analyser = in Odoc_type.Type_record (List.map f l) + let erased_names_of_constraints constraints acc = + List.fold_right (fun (longident, constraint_) acc -> + match constraint_ with + | Parsetree.Pwith_type _ | Parsetree.Pwith_module _ -> acc + | Parsetree.Pwith_typesubst _ | Parsetree.Pwith_modsubst _ -> + Name.Set.add (Name.from_longident longident.txt) acc) + constraints acc + + let filter_out_erased_items_from_signature erased signature = + if Name.Set.is_empty erased then signature + else List.fold_right (fun sig_item acc -> + let take_item psig_desc = { sig_item with Parsetree.psig_desc } :: acc in + match sig_item.Parsetree.psig_desc with + | Parsetree.Psig_value (_, _) + | Parsetree.Psig_exception (_, _) + | Parsetree.Psig_open _ + | Parsetree.Psig_include _ + | Parsetree.Psig_class _ + | Parsetree.Psig_class_type _ as tp -> take_item tp + | Parsetree.Psig_type types -> + (match List.filter (fun (name, _) -> not (Name.Set.mem name.txt erased)) types with + | [] -> acc + | types -> take_item (Parsetree.Psig_type types)) + | Parsetree.Psig_module (name, _) + | Parsetree.Psig_modtype (name, _) as m -> + if Name.Set.mem name.txt erased then acc else take_item m + | Parsetree.Psig_recmodule mods -> + (match List.filter (fun (name, _) -> not (Name.Set.mem name.txt erased)) mods with + | [] -> acc + | mods -> take_item (Parsetree.Psig_recmodule mods))) + signature [] + (** Analysis of the elements of a class, from the information in the parsetree and in the class signature. @return the couple (inherited_class list, elements).*) let analyse_class_elements env current_class_name last_pos pos_limit @@ -1013,7 +1045,8 @@ module Analyser = (maybe_more, new_env, eles) (** Return a module_type_kind from a Parsetree.module_type and a Types.module_type *) - and analyse_module_type_kind env current_module_name module_type sig_module_type = + and analyse_module_type_kind + ?(erased = Name.Set.empty) env current_module_name module_type sig_module_type = match module_type.Parsetree.pmty_desc with Parsetree.Pmty_ident longident -> let name = @@ -1027,6 +1060,7 @@ module Analyser = | Parsetree.Pmty_signature ast -> ( + let ast = filter_out_erased_items_from_signature erased ast in (* we must have a signature in the module type *) match sig_module_type with Types.Mty_signature signat -> @@ -1057,7 +1091,7 @@ module Analyser = mp_kind = mp_kind ; } in - let k = analyse_module_type_kind env + let k = analyse_module_type_kind ~erased env current_module_name module_type2 body_module_type @@ -1069,13 +1103,15 @@ module Analyser = raise (Failure "Parsetree.Pmty_functor _ but not Types.Mty_functor _") ) - | Parsetree.Pmty_with (module_type2, _) -> + | Parsetree.Pmty_with (module_type2, constraints) -> (* of module_type * (Longident.t * with_constraint) list *) ( let loc_start = module_type2.Parsetree.pmty_loc.Location.loc_end.Lexing.pos_cnum in let loc_end = module_type.Parsetree.pmty_loc.Location.loc_end.Lexing.pos_cnum in let s = get_string_of_file loc_start loc_end in - let k = analyse_module_type_kind env current_module_name module_type2 sig_module_type in + let erased = erased_names_of_constraints constraints erased in + let k = analyse_module_type_kind ~erased env current_module_name module_type2 sig_module_type in + Module_type_with (k, s) ) @@ -1086,7 +1122,8 @@ module Analyser = Module_type_typeof s (** analyse of a Parsetree.module_type and a Types.module_type.*) - and analyse_module_kind env current_module_name module_type sig_module_type = + and analyse_module_kind + ?(erased = Name.Set.empty) env current_module_name module_type sig_module_type = match module_type.Parsetree.pmty_desc with Parsetree.Pmty_ident longident -> let k = analyse_module_type_kind env current_module_name module_type sig_module_type in @@ -1094,6 +1131,7 @@ module Analyser = | Parsetree.Pmty_signature signature -> ( + let signature = filter_out_erased_items_from_signature erased signature in match sig_module_type with Types.Mty_signature signat -> Module_struct @@ -1128,7 +1166,7 @@ module Analyser = mp_kind = mp_kind ; } in - let k = analyse_module_kind env + let k = analyse_module_kind ~erased env current_module_name module_type2 body_module_type @@ -1139,13 +1177,14 @@ module Analyser = (* if we're here something's wrong *) raise (Failure "Parsetree.Pmty_functor _ but not Types.Mty_functor _") ) - | Parsetree.Pmty_with (module_type2, _) -> + | Parsetree.Pmty_with (module_type2, constraints) -> (*of module_type * (Longident.t * with_constraint) list*) ( let loc_start = module_type2.Parsetree.pmty_loc.Location.loc_end.Lexing.pos_cnum in let loc_end = module_type.Parsetree.pmty_loc.Location.loc_end.Lexing.pos_cnum in let s = get_string_of_file loc_start loc_end in - let k = analyse_module_type_kind env current_module_name module_type2 sig_module_type in + let erased = erased_names_of_constraints constraints erased in + let k = analyse_module_type_kind ~erased env current_module_name module_type2 sig_module_type in Module_with (k, s) ) | Parsetree.Pmty_typeof module_expr -> diff --git a/ocamldoc/odoc_sig.mli b/ocamldoc/odoc_sig.mli index cd329970..cd2ca50a 100644 --- a/ocamldoc/odoc_sig.mli +++ b/ocamldoc/odoc_sig.mli @@ -9,7 +9,7 @@ (* *) (***********************************************************************) -(* $Id: odoc_sig.mli 12511 2012-05-30 13:29:48Z lefessan $ *) +(* $Id: odoc_sig.mli 12622 2012-06-21 05:46:28Z guesdon $ *) (** The module for analysing a signature and source code and creating modules, classes, ..., elements.*) @@ -156,7 +156,7 @@ module Analyser : (** Return a module_type_kind from a Parsetree.module_type and a Types.module_type *) val analyse_module_type_kind : - Odoc_env.env -> Odoc_name.t -> + ?erased:Odoc_name.Set.t -> Odoc_env.env -> Odoc_name.t -> Parsetree.module_type -> Types.module_type -> Odoc_module.module_type_kind diff --git a/otherlibs/bigarray/mmap_unix.c b/otherlibs/bigarray/mmap_unix.c index ec0bfec6..971c7495 100644 --- a/otherlibs/bigarray/mmap_unix.c +++ b/otherlibs/bigarray/mmap_unix.c @@ -11,7 +11,11 @@ /* */ /***********************************************************************/ -/* $Id: mmap_unix.c 12326 2012-04-09 10:22:59Z xleroy $ */ +/* $Id: mmap_unix.c 12582 2012-06-07 12:17:44Z xleroy $ */ + +/* Needed (under Linux at least) to get pwrite's prototype in unistd.h. + Must be defined before the first system .h is included. */ +#define _XOPEN_SOURCE 500 #include #include diff --git a/otherlibs/labltk/browser/searchpos.ml b/otherlibs/labltk/browser/searchpos.ml index 0e5ab033..30d25a9d 100644 --- a/otherlibs/labltk/browser/searchpos.ml +++ b/otherlibs/labltk/browser/searchpos.ml @@ -12,7 +12,7 @@ (* *) (*************************************************************************) -(* $Id: searchpos.ml 12511 2012-05-30 13:29:48Z lefessan $ *) +(* $Id: searchpos.ml 12681 2012-07-10 08:33:16Z garrigue $ *) open Asttypes open StdLabels @@ -819,7 +819,6 @@ and search_pos_expr ~pos exp = search_pos_class_structure ~pos cls | Texp_pack modexp -> search_pos_module_expr modexp ~pos - | _ -> assert false (* TODO ................................... *) end; add_found_str (`Exp(`Expr, exp.exp_type)) ~env:exp.exp_env ~loc:exp.exp_loc end diff --git a/otherlibs/labltk/support/cltkFile.c b/otherlibs/labltk/support/cltkFile.c index 812e3cc3..be7ee8f6 100644 --- a/otherlibs/labltk/support/cltkFile.c +++ b/otherlibs/labltk/support/cltkFile.c @@ -14,11 +14,7 @@ /* */ /***********************************************************************/ -/* $Id: cltkFile.c 11156 2011-07-27 14:17:02Z doligez $ */ - -#ifdef __CYGWIN__ -#define _WIN32 -#endif +/* $Id: cltkFile.c 12716 2012-07-16 20:01:36Z doligez $ */ #ifdef _WIN32 #include diff --git a/otherlibs/systhreads/Makefile b/otherlibs/systhreads/Makefile index 3d3f8fb6..502498f1 100644 --- a/otherlibs/systhreads/Makefile +++ b/otherlibs/systhreads/Makefile @@ -11,7 +11,7 @@ # # ######################################################################### -# $Id: Makefile 11156 2011-07-27 14:17:02Z doligez $ +# $Id: Makefile 12585 2012-06-08 11:35:37Z xleroy $ include ../../config/Makefile @@ -30,7 +30,7 @@ all: libthreads.a threads.cma allopt: libthreadsnat.a threads.cmxa libthreads.a: $(BYTECODE_C_OBJS) - $(MKLIB) -o threads $(BYTECODE_C_OBJS) + $(MKLIB) -o threads $(BYTECODE_C_OBJS) -lpthread st_stubs_b.o: st_stubs.c st_posix.h $(BYTECC) -O -I../../byterun $(BYTECCCOMPOPTS) $(SHAREDCCCOMPOPTS) \ diff --git a/parsing/parser.mly b/parsing/parser.mly index f20f77de..cf48b9bb 100644 --- a/parsing/parser.mly +++ b/parsing/parser.mly @@ -10,7 +10,7 @@ /* */ /***********************************************************************/ -/* $Id: parser.mly 12511 2012-05-30 13:29:48Z lefessan $ */ +/* $Id: parser.mly 12638 2012-06-21 17:10:58Z frisch $ */ /* The parser definition */ @@ -1212,18 +1212,19 @@ expr_comma_list: | expr COMMA expr { [$3; $1] } ; record_expr: - simple_expr WITH lbl_expr_list opt_semi { (Some $1, List.rev $3) } - | lbl_expr_list opt_semi { (None, List.rev $1) } + simple_expr WITH lbl_expr_list { (Some $1, $3) } + | lbl_expr_list { (None, $1) } ; lbl_expr_list: + lbl_expr { [$1] } + | lbl_expr SEMI lbl_expr_list { $1 :: $3 } + | lbl_expr SEMI { [$1] } +; +lbl_expr: label_longident EQUAL expr - { [mkrhs $1 1,$3] } + { (mkrhs $1 1,$3) } | label_longident - { [mkrhs $1 1, exp_of_label $1 1] } - | lbl_expr_list SEMI label_longident EQUAL expr - { (mkrhs $3 3, $5) :: $1 } - | lbl_expr_list SEMI label_longident - { (mkrhs $3 3, exp_of_label $3 3) :: $1 } + { (mkrhs $1 1, exp_of_label $1 1) } ; field_expr_list: label EQUAL expr @@ -1280,9 +1281,9 @@ simple_pattern: { mkpat(Ppat_variant($1, None)) } | SHARP type_longident { mkpat(Ppat_type (mkrhs $2 2)) } - | LBRACE lbl_pattern_list record_pattern_end RBRACE - { mkpat(Ppat_record(List.rev $2, $3)) } - | LBRACE lbl_pattern_list opt_semi error + | LBRACE lbl_pattern_list RBRACE + { let (fields, closed) = $2 in mkpat(Ppat_record(fields, closed)) } + | LBRACE lbl_pattern_list error { unclosed "{" 1 "}" 4 } | LBRACKET pattern_semi_list opt_semi RBRACKET { reloc_pat (mktailpat (List.rev $2)) } @@ -1319,14 +1320,16 @@ pattern_semi_list: | pattern_semi_list SEMI pattern { $3 :: $1 } ; lbl_pattern_list: - label_longident EQUAL pattern { [(mkrhs $1 1, $3)] } - | label_longident { [(mkrhs $1 1, pat_of_label $1 1)] } - | lbl_pattern_list SEMI label_longident EQUAL pattern { (mkrhs $3 3, $5) :: $1 } - | lbl_pattern_list SEMI label_longident { (mkrhs $3 3, pat_of_label $3 3) :: $1 } -; -record_pattern_end: - opt_semi { Closed } - | SEMI UNDERSCORE opt_semi { Open } + lbl_pattern { [$1], Closed } + | lbl_pattern SEMI { [$1], Closed } + | lbl_pattern SEMI UNDERSCORE opt_semi { [$1], Open } + | lbl_pattern SEMI lbl_pattern_list { let (fields, closed) = $3 in $1 :: fields, closed } +; +lbl_pattern: + label_longident EQUAL pattern + { (mkrhs $1 1,$3) } + | label_longident + { (mkrhs $1 1, pat_of_label $1 1) } ; /* Primitive declarations */ diff --git a/stdlib/scanf.mli b/stdlib/scanf.mli index df77b8b3..2e9d4bc3 100644 --- a/stdlib/scanf.mli +++ b/stdlib/scanf.mli @@ -11,7 +11,7 @@ (* *) (***********************************************************************) -(* $Id: scanf.mli 12230 2012-03-13 16:10:02Z doligez $ *) +(* $Id: scanf.mli 12571 2012-06-05 18:21:50Z doligez $ *) (** Formatted input functions. *) @@ -140,7 +140,7 @@ val open_in_bin : file_name -> in_channel;; *) val close_in : in_channel -> unit;; -(** Closes the [Pervasives.input_channel] associated with the given +(** Closes the [Pervasives.in_channel] associated with the given [Scanning.in_channel] formatted input channel. @since 3.12.0 *) diff --git a/stdlib/stream.ml b/stdlib/stream.ml index 6e6d08c7..454c0f4a 100644 --- a/stdlib/stream.ml +++ b/stdlib/stream.ml @@ -11,7 +11,7 @@ (* *) (***********************************************************************) -(* $Id: stream.ml 11156 2011-07-27 14:17:02Z doligez $ *) +(* $Id: stream.ml 12683 2012-07-10 10:01:57Z scherer $ *) (* The fields of type t are not mutable to preserve polymorphism of the empty stream. This is type safe because the empty stream is never @@ -21,8 +21,8 @@ type 'a t = { count : int; data : 'a data } and 'a data = Sempty | Scons of 'a * 'a data - | Sapp of 'a data * 'a data - | Slazy of 'a data Lazy.t + | Sapp of 'a data * 'a t + | Slazy of 'a t Lazy.t | Sgen of 'a gen | Sbuffio of buffio and 'a gen = { mutable curr : 'a option option; func : int -> 'a option } @@ -42,26 +42,37 @@ let fill_buff b = b.len <- input b.ic b.buff 0 (String.length b.buff); b.ind <- 0 ;; -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'. *) +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). *) Sempty | Scons (_, _) -> d - | Sapp (d1, d2) -> - begin match get_data count d1 with - Scons (a, d11) -> Scons (a, Sapp (d11, d2)) - | Sempty -> get_data count d2 + | 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 | _ -> assert false end - | Sgen {curr = Some None; func = _ } -> Sempty - | Sgen ({curr = Some(Some a); func = f} as g) -> + | Sgen {curr = Some None; _ } -> Sempty + | Sgen ({curr = Some(Some a); _ } as g) -> g.curr <- None; Scons(a, d) - | Sgen g -> - begin match g.func count with + | Sgen ({curr = None; _} as g) -> + (* Warning: anyone using g thinks that an item has been read *) + begin match g.func s.count with None -> g.curr <- Some(None); Sempty - | Some a -> Scons(a, d) - (* Warning: anyone using g thinks that an item has been read *) + | 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) end | Sbuffio b -> if b.ind >= b.len then fill_buff b; @@ -69,7 +80,10 @@ let rec get_data count 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 -> get_data count (Lazy.force f) + | Slazy f -> + let s2 = Lazy.force f in + set_count s s2.count; + get_data s s2.data ;; let rec peek s = @@ -78,14 +92,20 @@ let rec peek s = Sempty -> None | Scons (a, _) -> Some a | Sapp (_, _) -> - begin match get_data s.count s.data with - Scons(a, _) as d -> set_data s d; Some a + begin match get_data s s.data with + | Scons(a, _) as d -> set_data s d; Some a | Sempty -> None | _ -> assert false end - | 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 + | 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 | Sbuffio b -> if b.ind >= b.len then fill_buff b; if b.len == 0 then begin set_data s Sempty; None end @@ -157,18 +177,21 @@ let of_channel ic = (* Stream expressions builders *) -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)};; +(* 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 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 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 ()).data)};; +let slazy f = {count = 0; data = Slazy (lazy (f()))};; + +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))};; (* For debugging use *) @@ -188,11 +211,11 @@ and dump_data f = print_string ", "; dump_data f d; print_string ")" - | Sapp (d1, d2) -> + | Sapp (d1, s2) -> print_string "Sapp ("; dump_data f d1; print_string ", "; - dump_data f d2; + dump f s2; print_string ")" | Slazy _ -> print_string "Slazy" | Sgen _ -> print_string "Sgen" diff --git a/testsuite/Makefile b/testsuite/Makefile index b8aac46e..d454f53d 100644 --- a/testsuite/Makefile +++ b/testsuite/Makefile @@ -1,4 +1,4 @@ -# $Id: Makefile 11135 2011-07-21 07:13:25Z xclerc $ +# $Id: Makefile 12579 2012-06-06 15:46:37Z doligez $ BASEDIR=${PWD} NO_PRINT=`($(MAKE) empty --no-print-directory > /dev/null 2>&1) && echo '--no-print-directory' || echo ''` diff --git a/testsuite/makefiles/Makefile.one b/testsuite/makefiles/Makefile.one index 7b252160..9a7c5278 100644 --- a/testsuite/makefiles/Makefile.one +++ b/testsuite/makefiles/Makefile.one @@ -1,4 +1,4 @@ -# $Id: Makefile.one 12551 2012-06-04 11:40:59Z doligez $ +# $Id: Makefile.one 12649 2012-06-27 12:29:20Z doligez $ CMI_FILES=$(MODULES:=.cmi) CMO_FILES=$(MODULES:=.cmo) @@ -20,7 +20,7 @@ ADD_CFLAGS+=$(CUSTOM_FLAG) default: compile run -compile: $(ML_FILES) $(CMO_FILES) $(CMX_FILES) $(MAIN_MODULE).cmo $(MAIN_MODULE).cmx +compile: $(ML_FILES) $(CMO_FILES) $(MAIN_MODULE).cmo @for file in $(C_FILES); do \ $(NATIVECC) $(NATIVECCCOMPOPTS) -c -I$(TOPDIR)/byterun $$file.c; \ done; @@ -28,6 +28,7 @@ compile: $(ML_FILES) $(CMO_FILES) $(CMX_FILES) $(MAIN_MODULE).cmo $(MAIN_MODULE) @$(OCAMLC) $(ADD_COMPFLAGS) $(ADD_CFLAGS) -o program.byte $(O_FILES) $(CMA_FILES) $(CMO_FILES) $(ADD_CMO_FILES) $(MAIN_MODULE).cmo @if [ -z "$(BYTECODE_ONLY)" ]; then \ rm -f program.native program.native.exe; \ + $(MAKE) $(CMX_FILES) $(MAIN_MODULE).cmx; \ $(OCAMLOPT) $(ADD_COMPFLAGS) -o program.native $(O_FILES) $(CMXA_FILES) $(CMX_FILES) $(ADD_CMX_FILES) $(MAIN_MODULE).cmx; \ fi diff --git a/testsuite/makefiles/Makefile.several b/testsuite/makefiles/Makefile.several index 66a7674b..54df8236 100644 --- a/testsuite/makefiles/Makefile.several +++ b/testsuite/makefiles/Makefile.several @@ -1,4 +1,4 @@ -# $Id: Makefile.several 12551 2012-06-04 11:40:59Z doligez $ +# $Id: Makefile.several 12618 2012-06-19 14:17:41Z doligez $ CC=$(NATIVECC) $(NATIVECCCOMPOPTS) FC=$(FORTAN_COMPILER) @@ -47,12 +47,12 @@ run-file: sh `basename $(FILE) ml`runner; \ else \ ./program $(PROGRAM_ARGS) > `basename $(FILE) ml`result; \ - fi + fi || (echo " => failed" && exit 1) @if [ -f `basename $(FILE) ml`checker ]; then \ sh `basename $(FILE) ml`checker; \ else \ - $(DIFF) `basename $(FILE) ml`reference `basename $(FILE) ml`result > /dev/null || (echo " => failed" && exit 1); \ - fi + $(DIFF) `basename $(FILE) ml`reference `basename $(FILE) ml`result > /dev/null; \ + fi || (echo " => failed" && exit 1) promote: defaultpromote diff --git a/testsuite/tests/asmcomp/Makefile b/testsuite/tests/asmcomp/Makefile index fb1af49c..8143873d 100644 --- a/testsuite/tests/asmcomp/Makefile +++ b/testsuite/tests/asmcomp/Makefile @@ -1,4 +1,5 @@ BASEDIR=../.. + CC=$(NATIVECC) CFLAGS=$(NATIVECCCOMPOPTS) -g @@ -141,11 +142,11 @@ clean: defaultclean @rm -f parsecmm.ml parsecmm.mli lexcmm.ml @rm -f $(CASES:=.s) +include $(BASEDIR)/makefiles/Makefile.common + power.o: power-$(SYSTEM).o @cp power-$(SYSTEM).o power.o promote: -include $(BASEDIR)/makefiles/Makefile.common - arch: $(ARCH).o diff --git a/testsuite/tests/asmcomp/i386.S b/testsuite/tests/asmcomp/i386.S index fdda4de4..19041085 100644 --- a/testsuite/tests/asmcomp/i386.S +++ b/testsuite/tests/asmcomp/i386.S @@ -10,12 +10,13 @@ /* */ /***********************************************************************/ -/* $Id: i386.S 11156 2011-07-27 14:17:02Z doligez $ */ +/* $Id: i386.S 12649 2012-06-27 12:29:20Z doligez $ */ /* Linux with ELF binaries does not prefix identifiers with _. Linux with a.out binaries, FreeBSD, and NextStep do. */ -#ifdef SYS_linux_elf +#if defined(SYS_linux_elf) || defined(SYS_bsd_elf) \ + || defined(SYS_solaris) || defined(SYS_beos) || defined(SYS_gnu) #define G(x) x #define FUNCTION_ALIGN 16 #else diff --git a/testsuite/tests/asmcomp/sparc.S b/testsuite/tests/asmcomp/sparc.S index 7d17548d..8f2c8354 100644 --- a/testsuite/tests/asmcomp/sparc.S +++ b/testsuite/tests/asmcomp/sparc.S @@ -10,9 +10,9 @@ /* */ /***********************************************************************/ -/* $Id: sparc.S 11156 2011-07-27 14:17:02Z doligez $ */ +/* $Id: sparc.S 12649 2012-06-27 12:29:20Z doligez $ */ -#ifndef SYS_solaris +#if defined(SYS_solaris) || defined(SYS_elf) #define Call_gen_code _call_gen_code #define Caml_c_call _caml_c_call #else diff --git a/testsuite/tests/lib-scanf-2/Makefile b/testsuite/tests/lib-scanf-2/Makefile index 216b3963..7362fad9 100644 --- a/testsuite/tests/lib-scanf-2/Makefile +++ b/testsuite/tests/lib-scanf-2/Makefile @@ -2,10 +2,11 @@ BASEDIR=../.. default: compile run -compile: tscanf2_io.cmo tscanf2_io.cmx +compile: tscanf2_io.cmo @$(OCAMLC) unix.cma tscanf2_io.cmo -o master.byte tscanf2_master.ml @$(OCAMLC) tscanf2_io.cmo -o slave.byte tscanf2_slave.ml @if [ -z "$(BYTECODE_ONLY)" ]; then \ + $(MAKE) tscanf2_io.cmx; \ $(OCAMLOPT) unix.cmxa tscanf2_io.cmx -o master.native tscanf2_master.ml; \ $(OCAMLOPT) tscanf2_io.cmx -o slave.native tscanf2_slave.ml; \ fi diff --git a/testsuite/tests/lib-stream/Makefile b/testsuite/tests/lib-stream/Makefile new file mode 100644 index 00000000..65ecf125 --- /dev/null +++ b/testsuite/tests/lib-stream/Makefile @@ -0,0 +1,4 @@ +BASEDIR=../.. +MODULES=testing +include $(BASEDIR)/makefiles/Makefile.several +include $(BASEDIR)/makefiles/Makefile.common diff --git a/testsuite/tests/lib-stream/count_concat_bug.ml b/testsuite/tests/lib-stream/count_concat_bug.ml new file mode 100644 index 00000000..97ec6bce --- /dev/null +++ b/testsuite/tests/lib-stream/count_concat_bug.ml @@ -0,0 +1,57 @@ +let is_empty s = + try Stream.empty s; true with Stream.Failure -> false + +let test_icons = + let s = Stream.of_string "ab" in + let s = Stream.icons 'c' s in + Testing.test (Stream.next s = 'c'); + Testing.test (Stream.next s = 'a'); + Testing.test (Stream.next s = 'b'); + Testing.test (is_empty s); + () + +let test_lcons = + let s = Stream.of_string "ab" in + let s = Stream.lcons (fun () -> 'c') s in + Testing.test (Stream.next s = 'c'); + Testing.test (Stream.next s = 'a'); + Testing.test (Stream.next s = 'b'); + Testing.test (is_empty s); + () + +let test_iapp = + let s = Stream.of_string "ab" in + let s = Stream.iapp (Stream.of_list ['c']) s in + Testing.test (Stream.next s = 'c'); + Testing.test (Stream.next s = 'a'); + Testing.test (Stream.next s = 'b'); + Testing.test (is_empty s); + () + +let test_lapp_right = + let s1 = Stream.of_list ['c'] in + let s2 = Stream.of_string "ab" in + let s = Stream.lapp (fun () -> s1) s2 in + Testing.test (Stream.next s = 'c'); + Testing.test (Stream.next s = 'a'); + Testing.test (Stream.next s = 'b'); + Testing.test (is_empty s); + () + +let test_lapp_left = + let s1 = Stream.of_string "bc" in + let s2 = Stream.of_list ['a'] in + Testing.test (Stream.next s1 = 'b'); + let s = Stream.lapp (fun () -> s1) s2 in + Testing.test (Stream.next s = 'c'); + Testing.test (Stream.next s = 'a'); + Testing.test (is_empty s); + () + +let test_slazy = + let s = Stream.of_string "ab" in + Testing.test (Stream.next s = 'a'); + let s = Stream.slazy (fun () -> s) in + Testing.test (Stream.next s = 'b'); + Testing.test (is_empty s); + () diff --git a/testsuite/tests/lib-stream/count_concat_bug.reference b/testsuite/tests/lib-stream/count_concat_bug.reference new file mode 100644 index 00000000..acdc75ca --- /dev/null +++ b/testsuite/tests/lib-stream/count_concat_bug.reference @@ -0,0 +1,2 @@ +0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 +All tests succeeded. diff --git a/testsuite/tests/lib-threads/test1.checker b/testsuite/tests/lib-threads/test1.checker index cbfe7ce5..1d104572 100644 --- a/testsuite/tests/lib-threads/test1.checker +++ b/testsuite/tests/lib-threads/test1.checker @@ -1 +1 @@ -sort test1.result | diff -q test1.reference - +LC_ALL=C sort test1.result | diff -q test1.reference - diff --git a/testsuite/tests/lib-threads/test4.checker b/testsuite/tests/lib-threads/test4.checker index ae27a0d5..b8661a98 100644 --- a/testsuite/tests/lib-threads/test4.checker +++ b/testsuite/tests/lib-threads/test4.checker @@ -1 +1 @@ -sort -u test4.result | diff -q test4.reference - +LC_ALL=C sort -u test4.result | diff -q test4.reference - diff --git a/testsuite/tests/lib-threads/test5.checker b/testsuite/tests/lib-threads/test5.checker index 030fcc91..e9918757 100644 --- a/testsuite/tests/lib-threads/test5.checker +++ b/testsuite/tests/lib-threads/test5.checker @@ -1 +1 @@ -sort -u test5.result | diff -q test5.reference - +LC_ALL=C sort -u test5.result | diff -q test5.reference - diff --git a/testsuite/tests/lib-threads/test6.checker b/testsuite/tests/lib-threads/test6.checker index 40ab24f8..d2e9930a 100644 --- a/testsuite/tests/lib-threads/test6.checker +++ b/testsuite/tests/lib-threads/test6.checker @@ -1 +1 @@ -sort -u test6.result | diff -q test6.reference - +LC_ALL=C sort -u test6.result | diff -q test6.reference - diff --git a/testsuite/tests/lib-threads/testA.checker b/testsuite/tests/lib-threads/testA.checker index 4c309401..9f5d00a8 100644 --- a/testsuite/tests/lib-threads/testA.checker +++ b/testsuite/tests/lib-threads/testA.checker @@ -1 +1 @@ -sort testA.result | diff -q testA.reference - +LC_ALL=C sort testA.result | diff -q testA.reference - diff --git a/testsuite/tests/lib-threads/testexit.checker b/testsuite/tests/lib-threads/testexit.checker index 5834e5d0..c1182d6f 100644 --- a/testsuite/tests/lib-threads/testexit.checker +++ b/testsuite/tests/lib-threads/testexit.checker @@ -1 +1 @@ -sort testexit.result | diff -q testexit.reference - +LC_ALL=C sort testexit.result | diff -q testexit.reference - diff --git a/testsuite/tests/regression/pr5233/Makefile b/testsuite/tests/regression/pr5233/Makefile new file mode 100644 index 00000000..c7a1ed0e --- /dev/null +++ b/testsuite/tests/regression/pr5233/Makefile @@ -0,0 +1,4 @@ +MAIN_MODULE=pr5233 + +include ../../../makefiles/Makefile.one +include ../../../makefiles/Makefile.common diff --git a/testsuite/tests/regression/pr5233/pr5233.ml b/testsuite/tests/regression/pr5233/pr5233.ml new file mode 100644 index 00000000..d0b5f762 --- /dev/null +++ b/testsuite/tests/regression/pr5233/pr5233.ml @@ -0,0 +1,50 @@ +open Printf;; + +(* PR#5233: Create a dangling pointer and use it to access random parts + of the heap. *) + +(* The buggy weak array will end up in smuggle. *) +let smuggle = ref (Weak.create 1);; + +(* This will be the weak array (W). *) +let t = ref (Weak.create 1);; + +(* Set a finalisation function on W. *) +Gc.finalise (fun w -> smuggle := w) !t;; + +(* Free W and run its finalisation function. *) +t := Weak.create 1;; +Gc.full_major ();; + +(* smuggle now contains W, whose pointers are not erased, even + when the contents is deallocated. *) + +let size = 1_000_000;; + +let check o = + printf "checking..."; + match o with + | None -> printf " no value\n"; + | Some s -> + printf " value found / testing..."; + for i = 0 to size - 1 do + if s.[i] != ' ' then failwith "bad"; + done; + printf " ok\n"; +;; + +Weak.set !smuggle 0 (Some (String.make size ' '));; + +(* Check the data just to make sure. *) +check (Weak.get !smuggle 0);; + +(* Get a dangling pointer in W. *) +Gc.full_major ();; + +(* Fill the heap with other stuff. *) +let rec fill n accu = if n = 0 then accu else fill (n-1) (123 :: accu);; +let r = fill ((Gc.stat ()).Gc.heap_words / 3) [];; +Gc.minor ();; + +(* Now follow the dangling pointer and exhibit the problem. *) +check (Weak.get !smuggle 0);; diff --git a/testsuite/tests/regression/pr5233/pr5233.reference b/testsuite/tests/regression/pr5233/pr5233.reference new file mode 100644 index 00000000..ef728f63 --- /dev/null +++ b/testsuite/tests/regression/pr5233/pr5233.reference @@ -0,0 +1,2 @@ +checking... value found / testing... ok +checking... no value diff --git a/testsuite/tests/typing-gadts/pr5689.ml b/testsuite/tests/typing-gadts/pr5689.ml new file mode 100644 index 00000000..304f8e6c --- /dev/null +++ b/testsuite/tests/typing-gadts/pr5689.ml @@ -0,0 +1,74 @@ +type inkind = [ `Link | `Nonlink ] + +type _ inline_t = + | Text: string -> [< inkind > `Nonlink ] inline_t + | Bold: 'a inline_t list -> 'a inline_t + | Link: string -> [< inkind > `Link ] inline_t + | Mref: string * [ `Nonlink ] inline_t list -> [< inkind > `Link ] inline_t +;; + +let uppercase seq = + let rec process: type a. a inline_t -> a inline_t = function + | Text txt -> Text (String.uppercase txt) + | Bold xs -> Bold (List.map process xs) + | Link lnk -> Link lnk + | Mref (lnk, xs) -> Mref (lnk, List.map process xs) + in List.map process seq +;; + +type ast_t = + | Ast_Text of string + | Ast_Bold of ast_t list + | Ast_Link of string + | Ast_Mref of string * ast_t list +;; + +let inlineseq_from_astseq seq = + let rec process_nonlink = function + | Ast_Text txt -> Text txt + | Ast_Bold xs -> Bold (List.map process_nonlink xs) + | _ -> assert false in + let rec process_any = function + | Ast_Text txt -> Text txt + | Ast_Bold xs -> Bold (List.map process_any xs) + | Ast_Link lnk -> Link lnk + | Ast_Mref (lnk, xs) -> Mref (lnk, List.map process_nonlink xs) + in List.map process_any seq +;; + +(* OK *) +type _ linkp = + | Nonlink : [ `Nonlink ] linkp + | Maylink : inkind linkp +;; +let inlineseq_from_astseq seq = + let rec process : type a. a linkp -> ast_t -> a inline_t = + fun allow_link ast -> + match (allow_link, ast) with + | (Maylink, Ast_Text txt) -> Text txt + | (Nonlink, Ast_Text txt) -> Text txt + | (x, Ast_Bold xs) -> Bold (List.map (process x) xs) + | (Maylink, Ast_Link lnk) -> Link lnk + | (Nonlink, Ast_Link _) -> assert false + | (Maylink, Ast_Mref (lnk, xs)) -> + Mref (lnk, List.map (process Nonlink) xs) + | (Nonlink, Ast_Mref _) -> assert false + in List.map (process Maylink) seq +;; + +(* Bad *) +type _ linkp2 = Kind : 'a linkp -> ([< inkind ] as 'a) linkp2 +;; +let inlineseq_from_astseq seq = +let rec process : type a. a linkp2 -> ast_t -> a inline_t = + fun allow_link ast -> + match (allow_link, ast) with + | (Kind _, Ast_Text txt) -> Text txt + | (x, Ast_Bold xs) -> Bold (List.map (process x) xs) + | (Kind Maylink, Ast_Link lnk) -> Link lnk + | (Kind Nonlink, Ast_Link _) -> assert false + | (Kind Maylink, Ast_Mref (lnk, xs)) -> + Mref (lnk, List.map (process (Kind Nonlink)) xs) + | (Kind Nonlink, Ast_Mref _) -> assert false + in List.map (process (Kind Maylink)) seq +;; diff --git a/testsuite/tests/typing-gadts/pr5689.ml.principal.reference b/testsuite/tests/typing-gadts/pr5689.ml.principal.reference new file mode 100644 index 00000000..f1e142aa --- /dev/null +++ b/testsuite/tests/typing-gadts/pr5689.ml.principal.reference @@ -0,0 +1,28 @@ + +# type inkind = [ `Link | `Nonlink ] +type _ inline_t = + Text : string -> [< inkind > `Nonlink ] inline_t + | Bold : 'a inline_t list -> 'a inline_t + | Link : string -> [< inkind > `Link ] inline_t + | Mref : string * + [ `Nonlink ] inline_t list -> [< inkind > `Link ] inline_t +# val uppercase : 'a inline_t list -> 'a inline_t list = +# type ast_t = + Ast_Text of string + | Ast_Bold of ast_t list + | Ast_Link of string + | Ast_Mref of string * ast_t list +# val inlineseq_from_astseq : ast_t list -> inkind inline_t list = +# type _ linkp = Nonlink : [ `Nonlink ] linkp | Maylink : inkind linkp +# val inlineseq_from_astseq : ast_t list -> inkind inline_t list = +# type _ linkp2 = Kind : 'a linkp -> ([< inkind ] as 'a) linkp2 +# Characters 272-279: + | (Kind Maylink, Ast_Link lnk) -> Link lnk + ^^^^^^^ +Error: This pattern matches values of type inkind linkp + but a pattern was expected which matches values of type + ([< inkind ] as 'a) linkp + Type inkind = [ `Link | `Nonlink ] is not compatible with type + 'a = [< `Link | `Nonlink ] + Types for tag `Nonlink are incompatible +# diff --git a/testsuite/tests/typing-gadts/pr5689.ml.reference b/testsuite/tests/typing-gadts/pr5689.ml.reference new file mode 100644 index 00000000..f1e142aa --- /dev/null +++ b/testsuite/tests/typing-gadts/pr5689.ml.reference @@ -0,0 +1,28 @@ + +# type inkind = [ `Link | `Nonlink ] +type _ inline_t = + Text : string -> [< inkind > `Nonlink ] inline_t + | Bold : 'a inline_t list -> 'a inline_t + | Link : string -> [< inkind > `Link ] inline_t + | Mref : string * + [ `Nonlink ] inline_t list -> [< inkind > `Link ] inline_t +# val uppercase : 'a inline_t list -> 'a inline_t list = +# type ast_t = + Ast_Text of string + | Ast_Bold of ast_t list + | Ast_Link of string + | Ast_Mref of string * ast_t list +# val inlineseq_from_astseq : ast_t list -> inkind inline_t list = +# type _ linkp = Nonlink : [ `Nonlink ] linkp | Maylink : inkind linkp +# val inlineseq_from_astseq : ast_t list -> inkind inline_t list = +# type _ linkp2 = Kind : 'a linkp -> ([< inkind ] as 'a) linkp2 +# Characters 272-279: + | (Kind Maylink, Ast_Link lnk) -> Link lnk + ^^^^^^^ +Error: This pattern matches values of type inkind linkp + but a pattern was expected which matches values of type + ([< inkind ] as 'a) linkp + Type inkind = [ `Link | `Nonlink ] is not compatible with type + 'a = [< `Link | `Nonlink ] + Types for tag `Nonlink are incompatible +# diff --git a/testsuite/tests/typing-misc/Makefile b/testsuite/tests/typing-misc/Makefile new file mode 100644 index 00000000..5f42b705 --- /dev/null +++ b/testsuite/tests/typing-misc/Makefile @@ -0,0 +1,4 @@ +BASEDIR=../.. +include $(BASEDIR)/makefiles/Makefile.toplevel +include $(BASEDIR)/makefiles/Makefile.common + diff --git a/testsuite/tests/typing-misc/constraints.ml b/testsuite/tests/typing-misc/constraints.ml new file mode 100644 index 00000000..5408ca2c --- /dev/null +++ b/testsuite/tests/typing-misc/constraints.ml @@ -0,0 +1,16 @@ +type 'a t = [`A of 'a t t] as 'a;; (* fails *) + +type 'a t = [`A of 'a t t];; (* fails *) + +type 'a t = [`A of 'a t t] constraint 'a = 'a t;; + +type 'a t = [`A of 'a t] constraint 'a = 'a t;; + +type 'a t = [`A of 'a] as 'a;; + +type 'a v = [`A of u v] constraint 'a = t and t = u and u = t;; (* fails *) + +type 'a t = 'a;; +let f (x : 'a t as 'a) = ();; (* fails *) + +let f (x : 'a t) (y : 'a) = x = y;; diff --git a/testsuite/tests/typing-misc/constraints.ml.reference b/testsuite/tests/typing-misc/constraints.ml.reference new file mode 100644 index 00000000..fe520440 --- /dev/null +++ b/testsuite/tests/typing-misc/constraints.ml.reference @@ -0,0 +1,29 @@ + +# Characters 12-32: + type 'a t = [`A of 'a t t] as 'a;; (* fails *) + ^^^^^^^^^^^^^^^^^^^^ +Error: Constraints are not satisfied in this type. + Type + [ `A of 'a ] t t as 'a + should be an instance of + ([ `A of 'b t t ] as 'b) t +# Characters 5-27: + type 'a t = [`A of 'a t t];; (* fails *) + ^^^^^^^^^^^^^^^^^^^^^^ +Error: In the definition of t, type 'a t t should be 'a t +# type 'a t = [ `A of 'a t t ] constraint 'a = 'a t +# type 'a t = [ `A of 'a t ] constraint 'a = 'a t +# type 'a t = 'a constraint 'a = [ `A of 'a ] +# Characters 47-52: + type 'a v = [`A of u v] constraint 'a = t and t = u and u = t;; (* fails *) + ^^^^^ +Error: The type abbreviation t is cyclic +# type 'a t = 'a +# Characters 11-21: + let f (x : 'a t as 'a) = ();; (* fails *) + ^^^^^^^^^^ +Error: This alias is bound to type 'a t = 'a + but is used as an instance of type 'a + The type variable 'a occurs inside 'a +# val f : 'a t -> 'a -> bool = +# diff --git a/testsuite/tests/typing-misc/records.ml b/testsuite/tests/typing-misc/records.ml new file mode 100644 index 00000000..36fa5ec7 --- /dev/null +++ b/testsuite/tests/typing-misc/records.ml @@ -0,0 +1,12 @@ +(* undefined labels *) +type t = {x:int;y:int};; +{x=3;z=2};; +fun {x=3;z=2} -> ();; + +(* mixed labels *) +{x=3; contents=2};; + +(* private types *) +type u = private {mutable u:int};; +{u=3};; +fun x -> x.u <- 3;; diff --git a/testsuite/tests/typing-misc/records.ml.reference b/testsuite/tests/typing-misc/records.ml.reference new file mode 100644 index 00000000..d69991a2 --- /dev/null +++ b/testsuite/tests/typing-misc/records.ml.reference @@ -0,0 +1,25 @@ + +# type t = { x : int; y : int; } +# Characters 5-6: + {x=3;z=2};; + ^ +Error: Unbound record field label z +# Characters 9-10: + fun {x=3;z=2} -> ();; + ^ +Error: Unbound record field label z +# Characters 26-34: + {x=3; contents=2};; + ^^^^^^^^ +Error: The record field label Pervasives.contents belongs to the type + 'a ref but is mixed here with labels of type t +# type u = private { mutable u : int; } +# Characters 0-5: + {u=3};; + ^^^^^ +Error: Cannot create values of the private type u +# Characters 11-12: + fun x -> x.u <- 3;; + ^ +Error: Cannot assign field u of the private type u +# diff --git a/testsuite/tests/typing-typeparam/Makefile b/testsuite/tests/typing-typeparam/Makefile index 748631f9..5f42b705 100644 --- a/testsuite/tests/typing-typeparam/Makefile +++ b/testsuite/tests/typing-typeparam/Makefile @@ -1,7 +1,4 @@ -#MODULES= BASEDIR=../.. -MAIN_MODULE=newtype -ADD_COMPFLAGS=-w a - -include $(BASEDIR)/makefiles/Makefile.one +include $(BASEDIR)/makefiles/Makefile.toplevel include $(BASEDIR)/makefiles/Makefile.common + diff --git a/testsuite/tests/typing-typeparam/newtype.ml b/testsuite/tests/typing-typeparam/newtype.ml index 24eb2fcf..abe58763 100644 --- a/testsuite/tests/typing-typeparam/newtype.ml +++ b/testsuite/tests/typing-typeparam/newtype.ml @@ -1,6 +1,7 @@ let property (type t) () = let module M = struct exception E of t end in (fun x -> M.E x), (function M.E x -> Some x | _ -> None) +;; let () = let (int_inj, int_proj) = property () in @@ -13,15 +14,19 @@ let () = Printf.printf "%b\n%!" (int_proj s = None); Printf.printf "%b\n%!" (string_proj i = None); Printf.printf "%b\n%!" (string_proj s = None) - - - +;; let sort_uniq (type s) cmp l = let module S = Set.Make(struct type t = s let compare = cmp end) in S.elements (List.fold_right S.add l S.empty) +;; let () = print_endline (String.concat "," (sort_uniq compare [ "abc"; "xyz"; "abc" ])) +;; - +let f x (type a) (y : a) = (x = y);; (* Fails *) +class ['a] c = object (self) + method m : 'a -> 'a = fun x -> x + method n : 'a -> 'a = fun (type g) (x:g) -> self#m x +end;; (* Fails *) diff --git a/testsuite/tests/typing-typeparam/newtype.ml.reference b/testsuite/tests/typing-typeparam/newtype.ml.reference new file mode 100644 index 00000000..c28cf53a --- /dev/null +++ b/testsuite/tests/typing-typeparam/newtype.ml.reference @@ -0,0 +1,19 @@ + +# val property : unit -> ('a -> exn) * (exn -> 'a option) = +# false +true +true +false +# val sort_uniq : ('a -> 'a -> int) -> 'a list -> 'a list = +# abc,xyz +# Characters 33-34: + let f x (type a) (y : a) = (x = y);; (* Fails *) + ^ +Error: This expression has type a but an expression was expected of type a + The type constructor a would escape its scope +# Characters 117-118: + method n : 'a -> 'a = fun (type g) (x:g) -> self#m x + ^ +Error: This expression has type g but an expression was expected of type g + The type constructor g would escape its scope +# diff --git a/testsuite/tests/typing-typeparam/newtype.reference b/testsuite/tests/typing-typeparam/newtype.reference deleted file mode 100644 index ab102d7d..00000000 --- a/testsuite/tests/typing-typeparam/newtype.reference +++ /dev/null @@ -1,5 +0,0 @@ -false -true -true -false -abc,xyz diff --git a/tools/make-version-header.sh b/tools/make-version-header.sh new file mode 100755 index 00000000..22320ec1 --- /dev/null +++ b/tools/make-version-header.sh @@ -0,0 +1,43 @@ +#!/bin/sh + +######################################################################### +# # +# OCaml # +# # +# Damien Doligez, projet Gallium, INRIA Rocquencourt # +# # +# Copyright 2003 Institut National de Recherche en Informatique et # +# en Automatique. All rights reserved. As an exception to the # +# licensing rules of OCaml, this file is freely redistributable, # +# modified or not, without constraints. # +# # +######################################################################### + +# For maximal compatibility with older versions, we Use "ocamlc -v" +# instead of "ocamlc -vnum" or the VERSION file in .../lib/ocaml/. + +# This script extracts the components from an OCaml version number +# and provides them as C defines: +# OCAML_VERSION_MAJOR: the major version number +# OCAML_VERSION_MAJOR: the minor version number +# OCAML_VERSION_PATCHLEVEL: the patchlevel number if present, or 0 if absent +# OCAML_VERSION_ADDITIONAL: this is defined only if the additional-info +# field is present, and is a string that contains that field. +# Note that additional-info is always absent in officially-released +# versions of OCaml. + +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'`" +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 "$suffix" in + "") echo "#undef OCAML_VERSION_ADDITIONAL";; + *) echo "#define OCAML_VERSION_ADDITIONAL \"$suffix\"";; +esac diff --git a/tools/ocamldep.ml b/tools/ocamldep.ml index e7068580..8df3421f 100644 --- a/tools/ocamldep.ml +++ b/tools/ocamldep.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: ocamldep.ml 12387 2012-04-20 15:33:56Z doligez $ *) +(* $Id: ocamldep.ml 12620 2012-06-20 13:17:14Z doligez $ *) open Longident open Parsetree @@ -196,7 +196,7 @@ let preprocess sourcefile = None -> sourcefile | Some pp -> flush Pervasives.stdout; - let tmpfile = Filename.temp_file "ocamldeppp" "" in + let tmpfile = Filename.temp_file "ocamldep_pp" "" in let comm = Printf.sprintf "%s %s > %s" pp sourcefile tmpfile in if Sys.command comm <> 0 then begin Misc.remove_file tmpfile; @@ -256,7 +256,8 @@ let report_err source_file exn = | Sys_error msg -> Format.fprintf Format.err_formatter "@[I/O error:@ %s@]@." msg | Preprocessing_error -> - Format.fprintf Format.err_formatter "@[Preprocessing error on file %s@]@." + Format.fprintf Format.err_formatter + "@[Preprocessing error on file %s@]@." source_file | x -> raise x @@ -265,12 +266,14 @@ let read_parse_and_extract parse_function extract_function source_file = try let input_file = preprocess source_file in let ic = open_in_bin input_file in + let cleanup () = close_in ic; remove_preprocessed input_file in try let ast = parse_function ic in extract_function Depend.StringSet.empty ast; + cleanup (); !Depend.free_structure_names with x -> - close_in ic; remove_preprocessed input_file; raise x + cleanup (); raise x with x -> report_err source_file x; Depend.StringSet.empty @@ -295,13 +298,18 @@ let ml_file_dependencies source_file = let init_deps = if !all_dependencies then [source_file] else [] in let cmi_name = basename ^ ".cmi" in let init_deps, extra_targets = - if List.exists (fun ext -> Sys.file_exists (basename ^ ext)) !mli_synonyms + if List.exists (fun ext -> Sys.file_exists (basename ^ ext)) + !mli_synonyms then (cmi_name :: init_deps, cmi_name :: init_deps), [] - else (init_deps, init_deps), ( if !all_dependencies then [cmi_name] else [] ) in + else (init_deps, init_deps), + (if !all_dependencies then [cmi_name] else []) + in let (byt_deps, native_deps) = Depend.StringSet.fold (find_dependency ML) extracted_deps init_deps in - if not !native_only then print_dependencies (byte_targets @ extra_targets) byt_deps; + if not !native_only then begin + print_dependencies (byte_targets @ extra_targets) byt_deps; + end; print_dependencies (native_targets @ extra_targets) native_deps; end @@ -429,34 +437,34 @@ let _ = Clflags.classic := false; add_to_load_path Filename.current_dir_name; Arg.parse [ + "-all", Arg.Set all_dependencies, + " Generate dependencies on all files"; "-I", Arg.String add_to_load_path, " Add to the list of include directories"; "-impl", Arg.String (file_dependencies_as ML), - " Process as a .ml file"; + " Process as a .ml file"; "-intf", Arg.String (file_dependencies_as MLI), - " Process as a .mli file"; + " Process as a .mli file"; "-ml-synonym", Arg.String(add_to_synonym_list ml_synonyms), - " Consider as a synonym of the .ml extension"; + " Consider as a synonym of the .ml extension"; "-mli-synonym", Arg.String(add_to_synonym_list mli_synonyms), - " Consider as a synonym of the .mli extension"; - "-sort", Arg.Set sort_files, - " Sort files according to their dependencies"; + " Consider as a synonym of the .mli extension"; "-modules", Arg.Set raw_dependencies, - " Print module dependencies in raw form (not suitable for make)"; + " Print module dependencies in raw form (not suitable for make)"; "-native", Arg.Set native_only, - " Generate dependencies for a pure native-code project (no .cmo files)"; - "-all", Arg.Set all_dependencies, - " Generate dependencies on all files (not accommodating for make shortcomings)"; + " Generate dependencies for native-code only (no .cmo files)"; "-one-line", Arg.Set one_line, - " Output one line per file, regardless of the length"; + " Output one line per file, regardless of the length"; "-pp", Arg.String(fun s -> preprocessor := Some s), - " Pipe sources through preprocessor "; + " Pipe sources through preprocessor "; "-slash", Arg.Set force_slash, - " (Windows) Use forward slash / instead of backslash \\ in file paths"; + " (Windows) Use forward slash / instead of backslash \\ in file paths"; + "-sort", Arg.Set sort_files, + " Sort files according to their dependencies"; "-version", Arg.Unit print_version, - " Print version and exit"; + " Print version and exit"; "-vnum", Arg.Unit print_version_num, - " Print version number and exit"; + " Print version number and exit"; ] file_dependencies usage; 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 f114b132..b6c236ea 100644 --- a/tools/ocamlmklib.mlp +++ b/tools/ocamlmklib.mlp @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: ocamlmklib.mlp 12149 2012-02-10 16:15:24Z doligez $ *) +(* $Id: ocamlmklib.mlp 12723 2012-07-17 18:25:54Z doligez $ *) open Printf open Myocamlbuild_config @@ -28,6 +28,7 @@ and caml_opts = ref [] (* -ccopt to pass to ocamlc, ocamlopt *) and dynlink = ref supports_shared_libraries and failsafe = ref false (* whether to fall back on static build only *) and c_libs = ref [] (* libs to pass to mksharedlib and ocamlc -cclib *) +and c_Lopts = ref [] (* options to pass to mksharedlib and ocamlc -cclib *) and c_opts = ref [] (* options to pass to mksharedlib and ocamlc -ccopt *) and ld_opts = ref [] (* options to pass only to the linker *) and ocamlc = ref (compiler_path "ocamlc") @@ -93,7 +94,7 @@ let parse_arguments argv = else if starts_with s "-l" then c_libs := s :: !c_libs else if starts_with s "-L" then - (c_opts := s :: !c_opts; + (c_Lopts := s :: !c_Lopts; let l = chop_prefix s "-L" in if not (Filename.is_relative l) then rpath := l :: !rpath) else if s = "-ocamlc" then @@ -137,6 +138,8 @@ let parse_arguments argv = (fun r -> r := List.rev !r) [ bytecode_objs; native_objs; caml_libs; caml_opts; c_libs; c_objs; c_opts; ld_opts; rpath ]; +(* Put -L options in front of -l options in -cclib to mimic -ccopt behavior *) + c_libs := !c_Lopts @ !c_libs; if !output_c = "" then output_c := !output diff --git a/tools/typedtreeIter.ml b/tools/typedtreeIter.ml index 4af9a3a0..a4f45ec9 100644 --- a/tools/typedtreeIter.ml +++ b/tools/typedtreeIter.ml @@ -228,8 +228,11 @@ module MakeIterator(Iter : IteratorArgument) : sig Iter.enter_expression exp; List.iter (function (cstr, _) -> match cstr with - Texp_constraint (cty1, cty2) -> option iter_core_type cty1; option iter_core_type cty2 - | Texp_open (path, _, _) -> ()) + Texp_constraint (cty1, cty2) -> + option iter_core_type cty1; option iter_core_type cty2 + | Texp_open (path, _, _) -> () + | Texp_poly cto -> option iter_core_type cto + | Texp_newtype s -> ()) exp.exp_extra; begin match exp.exp_desc with @@ -322,11 +325,6 @@ module MakeIterator(Iter : IteratorArgument) : sig iter_class_structure cl | Texp_pack (mexpr) -> iter_module_expr mexpr - | Texp_poly (exp, None) -> iter_expression exp - | Texp_poly (exp, Some ct) -> - iter_expression exp; iter_core_type ct - | Texp_newtype (s, exp) -> - iter_expression exp end; Iter.leave_expression exp; diff --git a/tools/untypeast.ml b/tools/untypeast.ml index 7f44cff7..eb9ffbaf 100644 --- a/tools/untypeast.ml +++ b/tools/untypeast.ml @@ -176,15 +176,22 @@ and untype_pattern pat = and option f x = match x with None -> None | Some e -> Some (f e) +and untype_extra (extra, loc) sexp = + let desc = + match extra with + Texp_constraint (cty1, cty2) -> + Pexp_constraint (sexp, + option untype_core_type cty1, + option untype_core_type cty2) + | Texp_open (path, lid, _) -> Pexp_open (lid, sexp) + | Texp_poly cto -> Pexp_poly (sexp, option untype_core_type cto) + | Texp_newtype s -> Pexp_newtype (s, sexp) + in + { pexp_desc = desc; + pexp_loc = loc } + and untype_expression exp = let desc = - match exp.exp_extra with - (Texp_constraint (cty1, cty2), _) :: rem -> - Pexp_constraint (untype_expression { exp with exp_extra = rem }, - option untype_core_type cty1, option untype_core_type cty2) - | (Texp_open (path, lid, _), _) :: rem -> - Pexp_open (lid, untype_expression { exp with exp_extra = rem} ) - | [] -> match exp.exp_desc with Texp_ident (path, lid, _) -> Pexp_ident (lid) | Texp_constant cst -> Pexp_constant cst @@ -279,15 +286,10 @@ and untype_expression exp = Pexp_object (untype_class_structure cl) | Texp_pack (mexpr) -> Pexp_pack (untype_module_expr mexpr) - | Texp_poly (exp, None) -> Pexp_poly(untype_expression exp, None) - | Texp_poly (exp, Some ct) -> - Pexp_poly (untype_expression exp, Some (untype_core_type ct)) - | Texp_newtype (s, exp) -> - Pexp_newtype (s, untype_expression exp) in - { pexp_loc = exp.exp_loc; - pexp_desc = desc; - } + List.fold_right untype_extra exp.exp_extra + { pexp_loc = exp.exp_loc; + pexp_desc = desc } and untype_package_type pack = (pack.pack_txt, diff --git a/toplevel/genprintval.ml b/toplevel/genprintval.ml index 4eaa1495..1e89e0aa 100644 --- a/toplevel/genprintval.ml +++ b/toplevel/genprintval.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: genprintval.ml 12511 2012-05-30 13:29:48Z lefessan $ *) +(* $Id: genprintval.ml 12689 2012-07-10 14:54:19Z doligez $ *) (* To print values *) @@ -33,10 +33,10 @@ module type OBJ = module type EVALPATH = sig - type value - val eval_path: Path.t -> value + type valu + val eval_path: Path.t -> valu exception Error - val same_value: value -> value -> bool + val same_value: valu -> valu -> bool end module type S = @@ -52,7 +52,7 @@ module type S = Env.t -> t -> type_expr -> Outcometree.out_value end -module Make(O : OBJ)(EVP : EVALPATH with type value = O.t) = struct +module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct type t = O.t diff --git a/toplevel/genprintval.mli b/toplevel/genprintval.mli index bd45764e..0d1f7081 100644 --- a/toplevel/genprintval.mli +++ b/toplevel/genprintval.mli @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: genprintval.mli 11156 2011-07-27 14:17:02Z doligez $ *) +(* $Id: genprintval.mli 12689 2012-07-10 14:54:19Z doligez $ *) (* Printing of values *) @@ -29,10 +29,10 @@ module type OBJ = module type EVALPATH = sig - type value - val eval_path: Path.t -> value + type valu + val eval_path: Path.t -> valu exception Error - val same_value: value -> value -> bool + val same_value: valu -> valu -> bool end module type S = @@ -48,5 +48,5 @@ module type S = Env.t -> t -> type_expr -> Outcometree.out_value end -module Make(O : OBJ)(EVP : EVALPATH with type value = O.t) : +module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) : (S with type t = O.t) diff --git a/toplevel/topdirs.ml b/toplevel/topdirs.ml index 0af7a2c9..56181052 100644 --- a/toplevel/topdirs.ml +++ b/toplevel/topdirs.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: topdirs.ml 12184 2012-02-23 19:54:44Z doligez $ *) +(* $Id: topdirs.ml 12661 2012-07-07 11:41:17Z scherer $ *) (* Toplevel directives *) @@ -41,6 +41,16 @@ let dir_directory s = let _ = Hashtbl.add directive_table "directory" (Directive_string dir_directory) +(* To remove a directory from the load path *) +let dir_remove_directory s = + let d = expand_directory Config.standard_library s in + Config.load_path := List.filter (fun d' -> d' <> d) !Config.load_path; + Dll.remove_path [d] + +let _ = + Hashtbl.add directive_table "remove_directory" + (Directive_string dir_remove_directory) + (* To change the current directory *) let dir_cd s = Sys.chdir s diff --git a/toplevel/topdirs.mli b/toplevel/topdirs.mli index f831bc08..ffcecca2 100644 --- a/toplevel/topdirs.mli +++ b/toplevel/topdirs.mli @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: topdirs.mli 11156 2011-07-27 14:17:02Z doligez $ *) +(* $Id: topdirs.mli 12661 2012-07-07 11:41:17Z scherer $ *) (* The toplevel directives. *) @@ -18,6 +18,7 @@ open Format val dir_quit : unit -> unit val dir_directory : string -> unit +val dir_remove_directory : string -> unit val dir_cd : string -> unit val dir_load : formatter -> string -> unit val dir_use : formatter -> string -> unit diff --git a/toplevel/toploop.ml b/toplevel/toploop.ml index 90e8dab3..88bd3ccc 100644 --- a/toplevel/toploop.ml +++ b/toplevel/toploop.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: toploop.ml 12542 2012-06-01 14:06:31Z frisch $ *) +(* $Id: toploop.ml 12689 2012-07-10 14:54:19Z doligez $ *) (* The interactive toplevel loop *) @@ -66,7 +66,7 @@ let rec eval_path = function (* To print values *) module EvalPath = struct - type value = Obj.t + type valu = Obj.t exception Error let eval_path p = try eval_path p with Symtable.Error _ -> raise Error let same_value v1 v2 = (v1 == v2) diff --git a/typing/btype.ml b/typing/btype.ml index 72f3e6c1..a036222b 100644 --- a/typing/btype.ml +++ b/typing/btype.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: btype.ml 12534 2012-06-01 05:24:38Z garrigue $ *) +(* $Id: btype.ml 12726 2012-07-18 03:34:36Z garrigue $ *) (* Basic operations on core types *) @@ -126,6 +126,14 @@ let rec row_more row = | {desc=Tvariant row'} -> row_more row' | ty -> ty +let row_fixed row = + let row = row_repr row in + row.row_fixed || + match (repr row.row_more).desc with + Tvar _ | Tnil -> false + | Tunivar _ | Tconstr _ -> true + | _ -> assert false + let static_row row = let row = row_repr row in row.row_closed && diff --git a/typing/btype.mli b/typing/btype.mli index 53d56036..ac863be8 100644 --- a/typing/btype.mli +++ b/typing/btype.mli @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: btype.mli 12534 2012-06-01 05:24:38Z garrigue $ *) +(* $Id: btype.mli 12726 2012-07-18 03:34:36Z garrigue $ *) (* Basic operations on core types *) @@ -64,6 +64,8 @@ val row_field: label -> row_desc -> row_field (* Return the canonical representative of a row field *) val row_more: row_desc -> type_expr (* Return the extension variable of the row *) +val row_fixed: row_desc -> bool + (* Return whether the row should be treated as fixed or not *) val static_row: row_desc -> bool (* Return whether the row is static or not *) val hash_variant: label -> int diff --git a/typing/cmt_format.ml b/typing/cmt_format.ml index 04545a8e..41bc08ea 100644 --- a/typing/cmt_format.ml +++ b/typing/cmt_format.ml @@ -19,6 +19,8 @@ open Typedtree integrated in Typerex). *) + + let read_magic_number ic = let len_magic_number = String.length Config.cmt_magic_number in let magic_number = String.create len_magic_number in @@ -54,11 +56,856 @@ type cmt_infos = { cmt_initial_env : Env.t; cmt_imports : (string * Digest.t) list; cmt_interface_digest : Digest.t option; + cmt_use_summaries : bool; } type error = Not_a_typedtree of string + + + + + + + +let need_to_clear_env = + try ignore (Sys.getenv "OCAML_BINANNOT_WITHENV"); false + with Not_found -> true + +(* Re-introduce sharing after clearing environments *) +let env_hcons = Hashtbl.create 133 +let keep_only_summary env = + let new_env = Env.keep_only_summary env in + try + Hashtbl.find env_hcons new_env + with Not_found -> + Hashtbl.add env_hcons new_env new_env; + new_env +let clear_env_hcons () = Hashtbl.clear env_hcons + + + + +module TypedtreeMap : sig + + open Asttypes + open Typedtree + + module type MapArgument = sig + val enter_structure : structure -> structure + val enter_value_description : value_description -> value_description + val enter_type_declaration : type_declaration -> type_declaration + val enter_exception_declaration : + exception_declaration -> exception_declaration + val enter_pattern : pattern -> pattern + val enter_expression : expression -> expression + val enter_package_type : package_type -> package_type + val enter_signature : signature -> signature + val enter_signature_item : signature_item -> signature_item + val enter_modtype_declaration : modtype_declaration -> modtype_declaration + val enter_module_type : module_type -> module_type + val enter_module_expr : module_expr -> module_expr + val enter_with_constraint : with_constraint -> with_constraint + val enter_class_expr : class_expr -> class_expr + val enter_class_signature : class_signature -> class_signature + val enter_class_description : class_description -> class_description + val enter_class_type_declaration : + class_type_declaration -> class_type_declaration + val enter_class_infos : 'a class_infos -> 'a class_infos + val enter_class_type : class_type -> class_type + val enter_class_type_field : class_type_field -> class_type_field + val enter_core_type : core_type -> core_type + val enter_core_field_type : core_field_type -> core_field_type + val enter_class_structure : class_structure -> class_structure + val enter_class_field : class_field -> class_field + val enter_structure_item : structure_item -> structure_item + + val leave_structure : structure -> structure + val leave_value_description : value_description -> value_description + val leave_type_declaration : type_declaration -> type_declaration + val leave_exception_declaration : + exception_declaration -> exception_declaration + val leave_pattern : pattern -> pattern + val leave_expression : expression -> expression + val leave_package_type : package_type -> package_type + val leave_signature : signature -> signature + val leave_signature_item : signature_item -> signature_item + val leave_modtype_declaration : modtype_declaration -> modtype_declaration + val leave_module_type : module_type -> module_type + val leave_module_expr : module_expr -> module_expr + val leave_with_constraint : with_constraint -> with_constraint + val leave_class_expr : class_expr -> class_expr + val leave_class_signature : class_signature -> class_signature + val leave_class_description : class_description -> class_description + val leave_class_type_declaration : + class_type_declaration -> class_type_declaration + val leave_class_infos : 'a class_infos -> 'a class_infos + val leave_class_type : class_type -> class_type + val leave_class_type_field : class_type_field -> class_type_field + val leave_core_type : core_type -> core_type + val leave_core_field_type : core_field_type -> core_field_type + val leave_class_structure : class_structure -> class_structure + val leave_class_field : class_field -> class_field + val leave_structure_item : structure_item -> structure_item + + end + + module MakeMap : + functor + (Iter : MapArgument) -> + sig + val map_structure : structure -> structure + val map_pattern : pattern -> pattern + val map_structure_item : structure_item -> structure_item + val map_expression : expression -> expression + val map_class_expr : class_expr -> class_expr + + val map_signature : signature -> signature + val map_signature_item : signature_item -> signature_item + val map_module_type : module_type -> module_type + end + + module DefaultMapArgument : MapArgument + +end = struct + + open Asttypes + open Typedtree + + module type MapArgument = sig + val enter_structure : structure -> structure + val enter_value_description : value_description -> value_description + val enter_type_declaration : type_declaration -> type_declaration + val enter_exception_declaration : + exception_declaration -> exception_declaration + val enter_pattern : pattern -> pattern + val enter_expression : expression -> expression + val enter_package_type : package_type -> package_type + val enter_signature : signature -> signature + val enter_signature_item : signature_item -> signature_item + val enter_modtype_declaration : modtype_declaration -> modtype_declaration + val enter_module_type : module_type -> module_type + val enter_module_expr : module_expr -> module_expr + val enter_with_constraint : with_constraint -> with_constraint + val enter_class_expr : class_expr -> class_expr + val enter_class_signature : class_signature -> class_signature + val enter_class_description : class_description -> class_description + val enter_class_type_declaration : + class_type_declaration -> class_type_declaration + val enter_class_infos : 'a class_infos -> 'a class_infos + val enter_class_type : class_type -> class_type + val enter_class_type_field : class_type_field -> class_type_field + val enter_core_type : core_type -> core_type + val enter_core_field_type : core_field_type -> core_field_type + val enter_class_structure : class_structure -> class_structure + val enter_class_field : class_field -> class_field + val enter_structure_item : structure_item -> structure_item + + val leave_structure : structure -> structure + val leave_value_description : value_description -> value_description + val leave_type_declaration : type_declaration -> type_declaration + val leave_exception_declaration : + exception_declaration -> exception_declaration + val leave_pattern : pattern -> pattern + val leave_expression : expression -> expression + val leave_package_type : package_type -> package_type + val leave_signature : signature -> signature + val leave_signature_item : signature_item -> signature_item + val leave_modtype_declaration : modtype_declaration -> modtype_declaration + val leave_module_type : module_type -> module_type + val leave_module_expr : module_expr -> module_expr + val leave_with_constraint : with_constraint -> with_constraint + val leave_class_expr : class_expr -> class_expr + val leave_class_signature : class_signature -> class_signature + val leave_class_description : class_description -> class_description + val leave_class_type_declaration : + class_type_declaration -> class_type_declaration + val leave_class_infos : 'a class_infos -> 'a class_infos + val leave_class_type : class_type -> class_type + val leave_class_type_field : class_type_field -> class_type_field + val leave_core_type : core_type -> core_type + val leave_core_field_type : core_field_type -> core_field_type + val leave_class_structure : class_structure -> class_structure + val leave_class_field : class_field -> class_field + val leave_structure_item : structure_item -> structure_item + + end + + + module MakeMap(Map : MapArgument) = struct + + let may_map f v = + match v with + None -> v + | Some x -> Some (f x) + + + open Misc + open Asttypes + + let rec map_structure str = + let str = Map.enter_structure str in + let str_items = List.map map_structure_item str.str_items in + Map.leave_structure { str with str_items = str_items } + + and map_binding (pat, exp) = (map_pattern pat, map_expression exp) + + and map_bindings rec_flag list = + List.map map_binding list + + and map_structure_item item = + let item = Map.enter_structure_item item in + let str_desc = + match item.str_desc with + Tstr_eval exp -> Tstr_eval (map_expression exp) + | Tstr_value (rec_flag, list) -> + Tstr_value (rec_flag, map_bindings rec_flag list) + | Tstr_primitive (id, name, v) -> + Tstr_primitive (id, name, map_value_description v) + | Tstr_type list -> + Tstr_type (List.map ( + fun (id, name, decl) -> + (id, name, map_type_declaration decl) ) list) + | Tstr_exception (id, name, decl) -> + Tstr_exception (id, name, map_exception_declaration decl) + | Tstr_exn_rebind (id, name, path, lid) -> + Tstr_exn_rebind (id, name, path, lid) + | Tstr_module (id, name, mexpr) -> + Tstr_module (id, name, map_module_expr mexpr) + | Tstr_recmodule list -> + let list = + List.map (fun (id, name, mtype, mexpr) -> + (id, name, map_module_type mtype, map_module_expr mexpr) + ) list + in + Tstr_recmodule list + | Tstr_modtype (id, name, mtype) -> + Tstr_modtype (id, name, map_module_type mtype) + | Tstr_open (path, lid) -> Tstr_open (path, lid) + | Tstr_class list -> + let list = + List.map (fun (ci, string_list, virtual_flag) -> + let ci = Map.enter_class_infos ci in + let ci_expr = map_class_expr ci.ci_expr in + (Map.leave_class_infos { ci with ci_expr = ci_expr}, + string_list, virtual_flag) + ) list + in + Tstr_class list + | Tstr_class_type list -> + let list = List.map (fun (id, name, ct) -> + let ct = Map.enter_class_infos ct in + let ci_expr = map_class_type ct.ci_expr in + (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) + in + Map.leave_structure_item { item with str_desc = str_desc} + + and map_value_description v = + let v = Map.enter_value_description v in + let val_desc = map_core_type v.val_desc in + Map.leave_value_description { v with val_desc = val_desc } + + and map_type_declaration decl = + let decl = Map.enter_type_declaration decl in + let typ_cstrs = List.map (fun (ct1, ct2, loc) -> + (map_core_type ct1, + map_core_type ct2, + loc) + ) decl.typ_cstrs in + let typ_kind = match decl.typ_kind with + Ttype_abstract -> Ttype_abstract + | Ttype_variant list -> + let list = List.map (fun (s, name, cts, loc) -> + (s, name, List.map map_core_type cts, loc) + ) list in + Ttype_variant list + | Ttype_record list -> + let list = + List.map (fun (s, name, mut, ct, loc) -> + (s, name, mut, map_core_type ct, loc) + ) list in + Ttype_record list + in + let typ_manifest = + match decl.typ_manifest with + None -> None + | Some ct -> Some (map_core_type ct) + in + Map.leave_type_declaration { decl with typ_cstrs = typ_cstrs; + typ_kind = typ_kind; typ_manifest = typ_manifest } + + and map_exception_declaration decl = + let decl = Map.enter_exception_declaration decl in + let exn_params = List.map map_core_type decl.exn_params in + let decl = { exn_params = exn_params; + exn_exn = decl.exn_exn; + exn_loc = decl.exn_loc } in + Map.leave_exception_declaration decl; + + and map_pattern pat = + let pat = Map.enter_pattern pat in + let pat_desc = + match pat.pat_desc with + | Tpat_alias (pat1, p, text) -> + let pat1 = map_pattern pat1 in + Tpat_alias (pat1, p, text) + | Tpat_tuple list -> Tpat_tuple (List.map map_pattern list) + | Tpat_construct (path, lid, cstr_decl, args, arity) -> + Tpat_construct (path, lid, cstr_decl, + List.map map_pattern args, arity) + | Tpat_variant (label, pato, rowo) -> + let pato = match pato with + None -> pato + | Some pat -> Some (map_pattern pat) + in + Tpat_variant (label, pato, rowo) + | Tpat_record (list, closed) -> + Tpat_record (List.map (fun (path, lid, lab_desc, pat) -> + (path, lid, lab_desc, map_pattern pat) ) list, closed) + | Tpat_array list -> Tpat_array (List.map map_pattern list) + | Tpat_or (p1, p2, rowo) -> + Tpat_or (map_pattern p1, map_pattern p2, rowo) + | Tpat_lazy p -> Tpat_lazy (map_pattern p) + | Tpat_constant _ + | Tpat_any + | Tpat_var _ -> pat.pat_desc + + in + let pat_extra = List.map map_pat_extra pat.pat_extra in + Map.leave_pattern { pat with pat_desc = pat_desc; pat_extra = pat_extra } + + and map_pat_extra pat_extra = + match pat_extra with + | Tpat_constraint ct, loc -> (Tpat_constraint (map_core_type ct), loc) + | (Tpat_type _ | Tpat_unpack), _ -> pat_extra + + and map_expression exp = + let exp = Map.enter_expression exp in + let exp_desc = + match exp.exp_desc with + Texp_ident (_, _, _) + | Texp_constant _ -> exp.exp_desc + | Texp_let (rec_flag, list, exp) -> + Texp_let (rec_flag, + map_bindings rec_flag list, + map_expression exp) + | Texp_function (label, cases, partial) -> + Texp_function (label, map_bindings Nonrecursive cases, partial) + | Texp_apply (exp, list) -> + Texp_apply (map_expression exp, + List.map (fun (label, expo, optional) -> + let expo = + match expo with + None -> expo + | Some exp -> Some (map_expression exp) + in + (label, expo, optional) + ) list ) + | Texp_match (exp, list, partial) -> + Texp_match ( + map_expression exp, + map_bindings Nonrecursive list, + partial + ) + | Texp_try (exp, list) -> + Texp_try ( + map_expression exp, + map_bindings Nonrecursive list + ) + | Texp_tuple list -> + Texp_tuple (List.map map_expression list) + | Texp_construct (path, lid, cstr_desc, args, arity) -> + Texp_construct (path, lid, cstr_desc, + List.map map_expression args, arity ) + | Texp_variant (label, expo) -> + let expo =match expo with + None -> expo + | Some exp -> Some (map_expression exp) + in + Texp_variant (label, expo) + | Texp_record (list, expo) -> + let list = + List.map (fun (path, lid, lab_desc, exp) -> + (path, lid, lab_desc, map_expression exp) + ) list in + let expo = match expo with + None -> expo + | Some exp -> Some (map_expression exp) + in + Texp_record (list, expo) + | Texp_field (exp, path, lid, label) -> + Texp_field (map_expression exp, path, lid, label) + | Texp_setfield (exp1, path, lid, label, exp2) -> + Texp_setfield ( + map_expression exp1, + path, lid, + label, + map_expression exp2) + | Texp_array list -> + Texp_array (List.map map_expression list) + | Texp_ifthenelse (exp1, exp2, expo) -> + Texp_ifthenelse ( + map_expression exp1, + map_expression exp2, + match expo with + None -> expo + | Some exp -> Some (map_expression exp) + ) + | Texp_sequence (exp1, exp2) -> + Texp_sequence ( + map_expression exp1, + map_expression exp2 + ) + | Texp_while (exp1, exp2) -> + Texp_while ( + map_expression exp1, + map_expression exp2 + ) + | Texp_for (id, name, exp1, exp2, dir, exp3) -> + Texp_for ( + id, name, + map_expression exp1, + map_expression exp2, + dir, + map_expression exp3 + ) + | Texp_when (exp1, exp2) -> + Texp_when ( + map_expression exp1, + map_expression exp2 + ) + | Texp_send (exp, meth, expo) -> + Texp_send (map_expression exp, meth, may_map map_expression expo) + | Texp_new (path, lid, cl_decl) -> exp.exp_desc + | Texp_instvar (_, path, _) -> exp.exp_desc + | Texp_setinstvar (path, lid, path2, exp) -> + Texp_setinstvar (path, lid, path2, map_expression exp) + | Texp_override (path, list) -> + Texp_override ( + path, + List.map (fun (path, lid, exp) -> + (path, lid, map_expression exp) + ) list + ) + | Texp_letmodule (id, name, mexpr, exp) -> + Texp_letmodule ( + id, name, + map_module_expr mexpr, + map_expression exp + ) + | Texp_assert exp -> Texp_assert (map_expression exp) + | Texp_assertfalse -> exp.exp_desc + | Texp_lazy exp -> Texp_lazy (map_expression exp) + | Texp_object (cl, string_list) -> + Texp_object (map_class_structure cl, string_list) + | Texp_pack (mexpr) -> + Texp_pack (map_module_expr mexpr) + in + let exp_extra = List.map map_exp_extra exp.exp_extra in + Map.leave_expression { + exp with + exp_desc = exp_desc; + exp_extra = exp_extra } + + and map_exp_extra exp_extra = + let loc = snd exp_extra in + match fst exp_extra with + | Texp_constraint (Some ct, None) -> + Texp_constraint (Some (map_core_type ct), None), loc + | Texp_constraint (None, Some ct) -> + Texp_constraint (None, Some (map_core_type ct)), loc + | Texp_constraint (Some ct1, Some ct2) -> + Texp_constraint (Some (map_core_type ct1), + Some (map_core_type ct2)), loc + | Texp_poly (Some ct) -> + Texp_poly (Some ( map_core_type ct )), loc + | Texp_newtype _ + | Texp_constraint (None, None) + | Texp_open _ + | Texp_poly None -> exp_extra + + + and map_package_type pack = + let pack = Map.enter_package_type pack in + let pack_fields = List.map ( + fun (s, ct) -> (s, map_core_type ct) ) pack.pack_fields in + Map.leave_package_type { pack with pack_fields = pack_fields } + + and map_signature sg = + let sg = Map.enter_signature sg in + let sig_items = List.map map_signature_item sg.sig_items in + Map.leave_signature { sg with sig_items = sig_items } + + and map_signature_item item = + let item = Map.enter_signature_item item in + let sig_desc = + match item.sig_desc with + Tsig_value (id, name, v) -> + Tsig_value (id, name, map_value_description v) + | Tsig_type list -> Tsig_type ( + List.map (fun (id, name, decl) -> + (id, name, map_type_declaration decl) + ) list + ) + | Tsig_exception (id, name, decl) -> + Tsig_exception (id, name, map_exception_declaration decl) + | Tsig_module (id, name, mtype) -> + Tsig_module (id, name, map_module_type mtype) + | Tsig_recmodule list -> + Tsig_recmodule (List.map ( + fun (id, name, mtype) -> + (id, name, map_module_type mtype) ) list) + | Tsig_modtype (id, name, mdecl) -> + Tsig_modtype (id, name, map_modtype_declaration mdecl) + | Tsig_open (path, lid) -> item.sig_desc + | Tsig_include (mty, lid) -> Tsig_include (map_module_type mty, lid) + | 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) + in + Map.leave_signature_item { item with sig_desc = sig_desc } + + and map_modtype_declaration mdecl = + let mdecl = Map.enter_modtype_declaration mdecl in + let mdecl = + match mdecl with + Tmodtype_abstract -> Tmodtype_abstract + | Tmodtype_manifest mtype -> + Tmodtype_manifest (map_module_type mtype) + in + Map.leave_modtype_declaration mdecl + + + and map_class_description cd = + let cd = Map.enter_class_description cd in + let ci_expr = map_class_type cd.ci_expr in + Map.leave_class_description { cd with ci_expr = ci_expr} + + and map_class_type_declaration cd = + let cd = Map.enter_class_type_declaration cd in + let ci_expr = map_class_type cd.ci_expr in + Map.leave_class_type_declaration { cd with ci_expr = ci_expr } + + and map_module_type mty = + let mty = Map.enter_module_type mty in + let mty_desc = + match mty.mty_desc with + Tmty_ident (path, lid) -> mty.mty_desc + | Tmty_signature sg -> Tmty_signature (map_signature sg) + | Tmty_functor (id, name, mtype1, mtype2) -> + Tmty_functor (id, name, map_module_type mtype1, + map_module_type mtype2) + | Tmty_with (mtype, list) -> + Tmty_with (map_module_type mtype, + List.map (fun (path, lid, withc) -> + (path, lid, map_with_constraint withc) + ) list) + | Tmty_typeof mexpr -> + Tmty_typeof (map_module_expr mexpr) + in + Map.leave_module_type { mty with mty_desc = mty_desc} + + and map_with_constraint cstr = + let cstr = Map.enter_with_constraint cstr in + let cstr = + match cstr with + Twith_type decl -> Twith_type (map_type_declaration decl) + | Twith_typesubst decl -> Twith_typesubst (map_type_declaration decl) + | Twith_module (path, lid) -> cstr + | Twith_modsubst (path, lid) -> cstr + in + Map.leave_with_constraint cstr + + and map_module_expr mexpr = + let mexpr = Map.enter_module_expr mexpr in + let mod_desc = + match mexpr.mod_desc with + Tmod_ident (p, lid) -> mexpr.mod_desc + | Tmod_structure st -> Tmod_structure (map_structure st) + | Tmod_functor (id, name, mtype, mexpr) -> + Tmod_functor (id, name, map_module_type mtype, + map_module_expr mexpr) + | Tmod_apply (mexp1, mexp2, coercion) -> + Tmod_apply (map_module_expr mexp1, map_module_expr mexp2, coercion) + | Tmod_constraint (mexpr, mod_type, Tmodtype_implicit, coercion ) -> + Tmod_constraint (map_module_expr mexpr, mod_type, + Tmodtype_implicit, coercion) + | Tmod_constraint (mexpr, mod_type, + Tmodtype_explicit mtype, coercion) -> + Tmod_constraint (map_module_expr mexpr, mod_type, + Tmodtype_explicit (map_module_type mtype), + coercion) + | Tmod_unpack (exp, mod_type) -> + Tmod_unpack (map_expression exp, mod_type) + in + Map.leave_module_expr { mexpr with mod_desc = mod_desc } + + and map_class_expr cexpr = + let cexpr = Map.enter_class_expr cexpr in + let cl_desc = + match cexpr.cl_desc with + | Tcl_constraint (cl, None, string_list1, string_list2, concr ) -> + Tcl_constraint (map_class_expr cl, None, string_list1, + string_list2, concr) + | Tcl_structure clstr -> Tcl_structure (map_class_structure clstr) + | Tcl_fun (label, pat, priv, cl, partial) -> + Tcl_fun (label, map_pattern pat, + List.map (fun (id, name, exp) -> + (id, name, map_expression exp)) priv, + map_class_expr cl, partial) + + | Tcl_apply (cl, args) -> + Tcl_apply (map_class_expr cl, + List.map (fun (label, expo, optional) -> + (label, may_map map_expression expo, + optional) + ) args) + | Tcl_let (rec_flat, bindings, ivars, cl) -> + Tcl_let (rec_flat, map_bindings rec_flat bindings, + List.map (fun (id, name, exp) -> + (id, name, map_expression exp)) ivars, + map_class_expr cl) + + | Tcl_constraint (cl, Some clty, vals, meths, concrs) -> + Tcl_constraint ( map_class_expr cl, + Some (map_class_type clty), vals, meths, concrs) + + | Tcl_ident (id, name, tyl) -> + Tcl_ident (id, name, List.map map_core_type tyl) + in + Map.leave_class_expr { cexpr with cl_desc = cl_desc } + + and map_class_type ct = + let ct = Map.enter_class_type ct in + let cltyp_desc = + match ct.cltyp_desc with + Tcty_signature csg -> Tcty_signature (map_class_signature csg) + | Tcty_constr (path, lid, list) -> + Tcty_constr (path, lid, List.map map_core_type list) + | Tcty_fun (label, ct, cl) -> + Tcty_fun (label, map_core_type ct, map_class_type cl) + in + Map.leave_class_type { ct with cltyp_desc = cltyp_desc } + + and map_class_signature cs = + let cs = Map.enter_class_signature cs in + let csig_self = map_core_type cs.csig_self in + let csig_fields = List.map map_class_type_field cs.csig_fields in + Map.leave_class_signature { cs with + csig_self = csig_self; csig_fields = csig_fields } + + + and map_class_type_field ctf = + let ctf = Map.enter_class_type_field ctf in + let ctf_desc = + match ctf.ctf_desc with + Tctf_inher ct -> Tctf_inher (map_class_type ct) + | Tctf_val (s, mut, virt, ct) -> + Tctf_val (s, mut, virt, map_core_type ct) + | Tctf_virt (s, priv, ct) -> + Tctf_virt (s, priv, map_core_type ct) + | Tctf_meth (s, priv, ct) -> + Tctf_meth (s, priv, map_core_type ct) + | Tctf_cstr (ct1, ct2) -> + Tctf_cstr (map_core_type ct1, map_core_type ct2) + in + Map.leave_class_type_field { ctf with ctf_desc = ctf_desc } + + and map_core_type ct = + let ct = Map.enter_core_type ct in + let ctyp_desc = + match ct.ctyp_desc with + Ttyp_any + | Ttyp_var _ -> ct.ctyp_desc + | Ttyp_arrow (label, ct1, ct2) -> + Ttyp_arrow (label, map_core_type ct1, map_core_type ct2) + | Ttyp_tuple list -> Ttyp_tuple (List.map map_core_type list) + | Ttyp_constr (path, lid, list) -> + Ttyp_constr (path, lid, List.map map_core_type list) + | Ttyp_object list -> Ttyp_object (List.map map_core_field_type list) + | Ttyp_class (path, lid, list, labels) -> + Ttyp_class (path, lid, List.map map_core_type list, labels) + | Ttyp_alias (ct, s) -> Ttyp_alias (map_core_type ct, s) + | Ttyp_variant (list, bool, labels) -> + Ttyp_variant (List.map map_row_field list, bool, labels) + | Ttyp_poly (list, ct) -> Ttyp_poly (list, map_core_type ct) + | Ttyp_package pack -> Ttyp_package (map_package_type pack) + in + Map.leave_core_type { ct with ctyp_desc = ctyp_desc } + + and map_core_field_type cft = + let cft = Map.enter_core_field_type cft in + let field_desc = match cft.field_desc with + Tcfield_var -> Tcfield_var + | Tcfield (s, ct) -> Tcfield (s, map_core_type ct) + in + Map.leave_core_field_type { cft with field_desc = field_desc } + + and map_class_structure cs = + let cs = Map.enter_class_structure cs in + let cstr_pat = map_pattern cs.cstr_pat in + let cstr_fields = List.map map_class_field cs.cstr_fields in + Map.leave_class_structure { cs with cstr_pat = cstr_pat; + cstr_fields = cstr_fields } + + and map_row_field rf = + match rf with + Ttag (label, bool, list) -> + Ttag (label, bool, List.map map_core_type list) + | Tinherit ct -> Tinherit (map_core_type ct) + + and map_class_field cf = + let cf = Map.enter_class_field cf in + let cf_desc = + match cf.cf_desc with + Tcf_inher (ovf, cl, super, vals, meths) -> + Tcf_inher (ovf, map_class_expr cl, super, vals, meths) + | Tcf_constr (cty, cty') -> + Tcf_constr (map_core_type cty, map_core_type cty') + | Tcf_val (lab, name, mut, ident, Tcfk_virtual cty, override) -> + Tcf_val (lab, name, mut, ident, Tcfk_virtual (map_core_type cty), + override) + | Tcf_val (lab, name, mut, ident, Tcfk_concrete exp, override) -> + Tcf_val (lab, name, mut, ident, Tcfk_concrete (map_expression exp), + override) + | Tcf_meth (lab, name, priv, Tcfk_virtual cty, override) -> + Tcf_meth (lab, name, priv, Tcfk_virtual (map_core_type cty), + override) + | Tcf_meth (lab, name, priv, Tcfk_concrete exp, override) -> + Tcf_meth (lab, name, priv, Tcfk_concrete (map_expression exp), + override) + | Tcf_init exp -> Tcf_init (map_expression exp) + in + Map.leave_class_field { cf with cf_desc = cf_desc } + + end + +module DefaultMapArgument = struct + + let enter_structure t = t + let enter_value_description t = t + let enter_type_declaration t = t + let enter_exception_declaration t = t + let enter_pattern t = t + let enter_expression t = t + let enter_package_type t = t + let enter_signature t = t + let enter_signature_item t = t + let enter_modtype_declaration t = t + let enter_module_type t = t + let enter_module_expr t = t + let enter_with_constraint t = t + let enter_class_expr t = t + let enter_class_signature t = t + let enter_class_description t = t + let enter_class_type_declaration t = t + let enter_class_infos t = t + let enter_class_type t = t + let enter_class_type_field t = t + let enter_core_type t = t + let enter_core_field_type t = t + let enter_class_structure t = t + let enter_class_field t = t + let enter_structure_item t = t + + + let leave_structure t = t + let leave_value_description t = t + let leave_type_declaration t = t + let leave_exception_declaration t = t + let leave_pattern t = t + let leave_expression t = t + let leave_package_type t = t + let leave_signature t = t + let leave_signature_item t = t + let leave_modtype_declaration t = t + let leave_module_type t = t + let leave_module_expr t = t + let leave_with_constraint t = t + let leave_class_expr t = t + let leave_class_signature t = t + let leave_class_description t = t + let leave_class_type_declaration t = t + let leave_class_infos t = t + let leave_class_type t = t + let leave_class_type_field t = t + let leave_core_type t = t + let leave_core_field_type t = t + let leave_class_structure t = t + let leave_class_field t = t + let leave_structure_item t = t + + end + +end + +module ClearEnv = TypedtreeMap.MakeMap (struct + open TypedtreeMap + include DefaultMapArgument + + let leave_pattern p = { p with pat_env = keep_only_summary p.pat_env } + let leave_expression e = + let exp_extra = List.map (function + (Texp_open (path, lloc, env), loc) -> + (Texp_open (path, lloc, keep_only_summary env), loc) + | exp_extra -> exp_extra) e.exp_extra in + { e with + exp_env = keep_only_summary e.exp_env; + exp_extra = exp_extra } + let leave_class_expr c = + { c with cl_env = keep_only_summary c.cl_env } + let leave_module_expr m = + { m with mod_env = keep_only_summary m.mod_env } + let leave_structure s = + { s with str_final_env = keep_only_summary s.str_final_env } + let leave_structure_item str = + { str with str_env = keep_only_summary str.str_env } + let leave_module_type m = + { m with mty_env = keep_only_summary m.mty_env } + let leave_signature s = + { s with sig_final_env = keep_only_summary s.sig_final_env } + let leave_signature_item s = + { s with sig_env = keep_only_summary s.sig_env } + let leave_core_type c = + { c with ctyp_env = keep_only_summary c.ctyp_env } + let leave_class_type c = + { c with cltyp_env = keep_only_summary c.cltyp_env } + +end) + +let rec clear_part p = match p with + | Partial_structure s -> Partial_structure (ClearEnv.map_structure s) + | Partial_structure_item s -> + Partial_structure_item (ClearEnv.map_structure_item s) + | Partial_expression e -> Partial_expression (ClearEnv.map_expression e) + | Partial_pattern p -> Partial_pattern (ClearEnv.map_pattern p) + | Partial_class_expr ce -> Partial_class_expr (ClearEnv.map_class_expr ce) + | Partial_signature s -> Partial_signature (ClearEnv.map_signature s) + | Partial_signature_item s -> + Partial_signature_item (ClearEnv.map_signature_item s) + | Partial_module_type s -> Partial_module_type (ClearEnv.map_module_type s) + +let clear_env binary_annots = + if need_to_clear_env then + match binary_annots with + | Implementation s -> Implementation (ClearEnv.map_structure s) + | Interface s -> Interface (ClearEnv.map_signature s) + | Packed _ -> binary_annots + | Partial_implementation array -> + Partial_implementation (Array.map clear_part array) + | Partial_interface array -> + Partial_interface (Array.map clear_part array) + + else binary_annots + + + + exception Error of error let input_cmt ic = (input_value ic : cmt_infos) @@ -69,7 +916,7 @@ let output_cmt oc cmt = let read filename = (* Printf.fprintf stderr "Cmt_format.read %s\n%!" filename; *) - let ic = open_in filename in + let ic = open_in_bin filename in try let magic_number = read_magic_number ic in let cmi, cmt = @@ -109,7 +956,8 @@ let read_cmt filename = let read_cmi filename = match read filename with - None, _ -> raise (Cmi_format.Error (Cmi_format.Not_an_interface filename)) + None, _ -> + raise (Cmi_format.Error (Cmi_format.Not_an_interface filename)) | Some cmi, _ -> cmi let saved_types = ref [] @@ -119,9 +967,12 @@ let get_saved_types () = !saved_types let set_saved_types l = saved_types := l let save_cmt filename modname binary_annots sourcefile initial_env sg = - if !Clflags.binary_annotations && not !Clflags.print_types then begin + if !Clflags.binary_annotations + && not !Clflags.print_types + && not !Clflags.dont_write_files + then begin let imports = Env.imported_units () in - let oc = open_out filename in + let oc = open_out_bin filename in let this_crc = match sg with None -> None @@ -138,17 +989,20 @@ let save_cmt filename modname binary_annots sourcefile initial_env sg = let source_digest = Misc.may_map Digest.file sourcefile in let cmt = { cmt_modname = modname; - cmt_annots = binary_annots; + cmt_annots = clear_env binary_annots; cmt_comments = Lexer.comments (); cmt_args = Sys.argv; cmt_sourcefile = sourcefile; cmt_builddir = Sys.getcwd (); cmt_loadpath = !Config.load_path; cmt_source_digest = source_digest; - cmt_initial_env = initial_env; + cmt_initial_env = if need_to_clear_env then + keep_only_summary initial_env else initial_env; cmt_imports = List.sort compare imports; cmt_interface_digest = this_crc; + cmt_use_summaries = need_to_clear_env; } in + clear_env_hcons (); output_cmt oc cmt; close_out oc; set_saved_types []; diff --git a/typing/cmt_format.mli b/typing/cmt_format.mli index ab49d0dd..578d1743 100644 --- a/typing/cmt_format.mli +++ b/typing/cmt_format.mli @@ -57,6 +57,7 @@ type cmt_infos = { cmt_initial_env : Env.t; cmt_imports : (string * Digest.t) list; cmt_interface_digest : Digest.t option; + cmt_use_summaries : bool; } type error = diff --git a/typing/ctype.ml b/typing/ctype.ml index ac984c46..f9a0294a 100644 --- a/typing/ctype.ml +++ b/typing/ctype.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: ctype.ml 12534 2012-06-01 05:24:38Z garrigue $ *) +(* $Id: ctype.ml 12726 2012-07-18 03:34:36Z garrigue $ *) (* Operations on core types *) @@ -2165,14 +2165,15 @@ and unify3 env t1 t1' t2 t2' = | (Tfield _, Tfield _) -> (* special case for GADTs *) unify_fields env t1' t2' | _ -> - begin match !umode with - | Expression -> - occur !env t1' t2'; - link_type t1' t2 - | Pattern -> - add_type_equality t1' t2' - end; - try match (d1, d2) with + begin match !umode with + | Expression -> + occur !env t1' t2'; + link_type t1' t2 + | Pattern -> + add_type_equality t1' t2' + end; + try + begin match (d1, d2) with (Tarrow (l1, t1, u1, c1), Tarrow (l2, t2, u2, c2)) when l1 = l2 || !Clflags.classic && not (is_optional l1 || is_optional l2) -> unify env t1 t2; unify env u1 u2; @@ -2246,20 +2247,20 @@ and unify3 env t1 t1' t2 t2' = unify_list env tl1 tl2 | (_, _) -> raise (Unify []) - with Unify trace -> - t1'.desc <- d1; - raise (Unify trace) - end; - (* XXX Commentaires + changer "create_recursion" *) - if create_recursion then begin - match t2.desc with - Tconstr (p, tl, abbrev) -> - forget_abbrev abbrev p; - let t2'' = expand_head_unif !env t2 in - if not (closed_parameterized_type tl t2'') then - link_type (repr t2) (repr t2') - | _ -> - () (* t2 has already been expanded by update_level *) + end; + (* XXX Commentaires + changer "create_recursion" *) + if create_recursion then + match t2.desc with + Tconstr (p, tl, abbrev) -> + forget_abbrev abbrev p; + let t2'' = expand_head_unif !env t2 in + if not (closed_parameterized_type tl t2'') then + link_type (repr t2) (repr t2') + | _ -> + () (* t2 has already been expanded by update_level *) + with Unify trace -> + t1'.desc <- d1; + raise (Unify trace) end and unify_list env tl1 tl2 = @@ -2339,11 +2340,12 @@ and unify_row env row1 row2 = with Not_found -> ()) r2 end; + let fixed1 = row_fixed row1 and fixed2 = row_fixed row2 in let more = - if row1.row_fixed then rm1 else - if row2.row_fixed then rm2 else + if fixed1 then rm1 else + if fixed2 then rm2 else newty2 (min rm1.level rm2.level) (Tvar None) in - let fixed = row1.row_fixed || row2.row_fixed + let fixed = fixed1 || fixed2 and closed = row1.row_closed || row2.row_closed in let keep switch = List.for_all @@ -2377,8 +2379,8 @@ and unify_row env row1 row2 = if closed then filter_row_fields row.row_closed rest else rest in - if rest <> [] && (row.row_closed || row.row_fixed) - || closed && row.row_fixed && not row.row_closed then begin + if rest <> [] && (row.row_closed || row_fixed row) + || closed && row_fixed row && not row.row_closed then begin let t1 = mkvariant [] true and t2 = mkvariant rest false in raise (Unify [if row == row1 then (t1,t2) else (t2,t1)]) end; @@ -2387,7 +2389,7 @@ and unify_row env row1 row2 = if !trace_gadt_instances && rm.desc = Tnil then () else if !trace_gadt_instances then update_level !env rm.level (newgenty (Tvariant row)); - if row.row_fixed then + if row_fixed row then if more == rm then () else if is_Tvar rm then link_type rm more else unify env rm more else @@ -2401,7 +2403,7 @@ and unify_row env row1 row2 = set_more row1 r2; List.iter (fun (l,f1,f2) -> - try unify_row_field env row1.row_fixed row2.row_fixed more l f1 f2 + try unify_row_field env fixed1 fixed2 more l f1 f2 with Unify trace -> raise (Unify ((mkvariant [l,f1] true, mkvariant [l,f2] true) :: trace))) @@ -2419,7 +2421,7 @@ and unify_row_field env fixed1 fixed2 more l f1 f2 = | Reither(c1, tl1, m1, e1), Reither(c2, tl2, m2, e2) -> if e1 == e2 then () else let redo = - (m1 || m2 || + (m1 || m2 || fixed1 || fixed2 || !rigid_variants && (List.length tl1 = 1 || List.length tl2 = 1)) && begin match tl1 @ tl2 with [] -> false | t1 :: tl -> @@ -2440,8 +2442,8 @@ and unify_row_field env fixed1 fixed2 more l f1 f2 = let f1' = Reither(c1 || c2, tl1', m1 || m2, e) and f2' = Reither(c1 || c2, tl2', m1 || m2, e) in set_row_field e1 f1'; set_row_field e2 f2'; - | Reither(_, _, false, e1), Rabsent -> set_row_field e1 f2 - | Rabsent, Reither(_, _, false, e2) -> set_row_field e2 f1 + | Reither(_, _, false, e1), Rabsent when not fixed1 -> set_row_field e1 f2 + | Rabsent, Reither(_, _, false, e2) when not fixed2 -> set_row_field e2 f1 | Rabsent, Rabsent -> () | Reither(false, tl, _, e1), Rpresent(Some t2) when not fixed1 -> set_row_field e1 f2; @@ -2834,7 +2836,7 @@ let rec rigidify_rec vars ty = | Tvariant row -> let row = row_repr row in let more = repr row.row_more in - if is_Tvar more && not row.row_fixed then begin + if is_Tvar more && not (row_fixed row) then begin let more' = newty2 more.level more.desc in let row' = {row with row_fixed=true; row_fields=[]; row_more=more'} in link_type more (newty2 ty.level (Tvariant row')) diff --git a/typing/env.ml b/typing/env.ml index 99e083bc..334a7378 100644 --- a/typing/env.ml +++ b/typing/env.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: env.ml 12542 2012-06-01 14:06:31Z frisch $ *) +(* $Id: env.ml 12706 2012-07-13 08:49:06Z lefessan $ *) (* Environment handling *) @@ -171,7 +171,7 @@ and structure_components = { mutable comp_annotations: (string, (Annot.ident * int)) Tbl.t; mutable comp_constrs: (string, (constructor_description * int)) Tbl.t; mutable comp_labels: (string, (label_description * int)) Tbl.t; - mutable comp_constrs_by_path: + mutable comp_constrs_by_path: (string, (constructor_description list * int)) Tbl.t; mutable comp_types: (string, (type_declaration * int)) Tbl.t; mutable comp_modules: @@ -195,11 +195,11 @@ let subst_modtype_maker (subst, mty) = Subst.modtype subst mty let empty = { values = EnvTbl.empty; annotations = EnvTbl.empty; constrs = EnvTbl.empty; - labels = EnvTbl.empty; types = EnvTbl.empty; + labels = EnvTbl.empty; types = EnvTbl.empty; constrs_by_path = EnvTbl.empty; modules = EnvTbl.empty; modtypes = EnvTbl.empty; components = EnvTbl.empty; classes = EnvTbl.empty; - cltypes = EnvTbl.empty; + cltypes = EnvTbl.empty; summary = Env_empty; local_constraints = false; gadt_instances = []; in_signature = false; } @@ -730,7 +730,7 @@ let rec scrape_modtype mty env = (* Compute constructor descriptions *) let constructors_of_type ty_path decl = - let handle_variants cstrs = + let handle_variants cstrs = Datarepr.constructor_descrs (newgenty (Tconstr(ty_path, decl.type_params, ref Mnil))) cstrs decl.type_private @@ -798,7 +798,7 @@ and components_of_module_maker (env, sub, path, mty) = Mty_signature sg -> let c = { comp_values = Tbl.empty; comp_annotations = Tbl.empty; - comp_constrs = Tbl.empty; + comp_constrs = Tbl.empty; comp_labels = Tbl.empty; comp_types = Tbl.empty; comp_constrs_by_path = Tbl.empty; comp_modules = Tbl.empty; comp_modtypes = Tbl.empty; @@ -827,7 +827,7 @@ and components_of_module_maker (env, sub, path, mty) = Tbl.add (Ident.name id) (decl', nopos) c.comp_types; let constructors = constructors_of_type path decl' in c.comp_constrs_by_path <- - Tbl.add (Ident.name id) + Tbl.add (Ident.name id) (List.map snd constructors, nopos) c.comp_constrs_by_path; List.iter (fun (name, descr) -> @@ -886,8 +886,8 @@ and components_of_module_maker (env, sub, path, mty) = | Mty_ident p -> Structure_comps { comp_values = Tbl.empty; comp_annotations = Tbl.empty; - comp_constrs = Tbl.empty; - comp_labels = Tbl.empty; + comp_constrs = Tbl.empty; + comp_labels = Tbl.empty; comp_types = Tbl.empty; comp_constrs_by_path = Tbl.empty; comp_modules = Tbl.empty; comp_modtypes = Tbl.empty; comp_components = Tbl.empty; comp_classes = Tbl.empty; @@ -956,8 +956,8 @@ and store_type id path info env = constructors env.constrs; - constrs_by_path = - EnvTbl.add id + constrs_by_path = + EnvTbl.add id (path,List.map snd constructors) env.constrs_by_path; labels = List.fold_right @@ -1303,6 +1303,19 @@ let initial = Predef.build_initial_env add_type add_exception empty (* Return the environment summary *) let summary env = env.summary +let keep_only_summary env = + { empty with + summary = env.summary; + local_constraints = env.local_constraints; + in_signature = env.in_signature; +} + +let env_of_only_summary env_from_summary env = + let new_env = env_from_summary env.summary Subst.identity in + { new_env with + local_constraints = env.local_constraints; + in_signature = env.in_signature; + } (* Error report *) diff --git a/typing/env.mli b/typing/env.mli index d8ca2837..fad7d773 100644 --- a/typing/env.mli +++ b/typing/env.mli @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: env.mli 12542 2012-06-01 14:06:31Z frisch $ *) +(* $Id: env.mli 12706 2012-07-13 08:49:06Z lefessan $ *) (* Environment handling *) @@ -141,6 +141,14 @@ val crc_units: Consistbl.t val summary: t -> summary +(* Return an equivalent environment where all fields have been reset, + except the summary. The initial environment can be rebuilt from the + summary, using Envaux.env_of_only_summary. *) + +val keep_only_summary : t -> t +val env_of_only_summary : (summary -> Subst.t -> t) -> t -> t + + (* Error report *) type error = diff --git a/typing/parmatch.ml b/typing/parmatch.ml index e23153c4..a0d42baf 100644 --- a/typing/parmatch.ml +++ b/typing/parmatch.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: parmatch.ml 12520 2012-05-31 07:41:37Z garrigue $ *) +(* $Id: parmatch.ml 12726 2012-07-18 03:34:36Z garrigue $ *) (* Detection of partial matches and unused match cases. *) @@ -653,7 +653,7 @@ let full_match ignore_generalized closing env = match env with env in let row = row_of_pat p in - if closing && not row.row_fixed then + if closing && not (Btype.row_fixed row) then (* closing=true, we are considering the variant as closed *) List.for_all (fun (tag,f) -> @@ -1239,7 +1239,7 @@ let rec pressure_variants tdefs = function begin match constrs, tdefs with ({pat_desc=Tpat_variant _} as p,_):: _, Some env -> let row = row_of_pat p in - if row.row_fixed + if Btype.row_fixed row || pressure_variants None (filter_extra pss) then () else close_variant env row | _ -> () diff --git a/typing/printtyped.ml b/typing/printtyped.ml index 28969ff1..55a0e2ec 100644 --- a/typing/printtyped.ml +++ b/typing/printtyped.ml @@ -230,19 +230,26 @@ and pattern i ppf x = line i ppf "Ppat_lazy\n"; pattern i ppf p; -and expression i ppf x = - line i ppf "expression %a\n" fmt_location x.exp_loc; - let i = i+1 in - match x.exp_extra with - | (Texp_constraint (cto1, cto2), _) :: rem -> +and expression_extra i ppf x = + match x with + | Texp_constraint (cto1, cto2) -> line i ppf "Pexp_constraint\n"; option i core_type ppf cto1; option i core_type ppf cto2; - expression i ppf { x with exp_extra = rem } - | (Texp_open (m, _,_), _) :: rem -> + | Texp_open (m, _, _) -> line i ppf "Pexp_open \"%a\"\n" fmt_path m; - expression i ppf { x with exp_extra = rem } - | [] -> + | Texp_poly cto -> + line i ppf "Pexp_poly\n"; + option i core_type ppf cto; + | Texp_newtype s -> + line i ppf "Pexp_newtype \"%s\"\n" s; + +and expression i ppf x = + line i ppf "expression %a\n" fmt_location x.exp_loc; + let i = + List.fold_left (fun i (extra,_) -> expression_extra i ppf extra; i+1) + (i+1) x.exp_extra + in match x.exp_desc with | Texp_ident (li,_,_) -> line i ppf "Pexp_ident %a\n" fmt_path li; | Texp_instvar (_, li,_) -> line i ppf "Pexp_instvar %a\n" fmt_path li; @@ -342,16 +349,9 @@ and expression i ppf x = | Texp_lazy (e) -> line i ppf "Pexp_lazy"; expression i ppf e; - | Texp_poly (e, cto) -> - line i ppf "Pexp_poly\n"; - expression i ppf e; - option i core_type ppf cto; | Texp_object (s, _) -> line i ppf "Pexp_object"; class_structure i ppf s - | Texp_newtype (s, e) -> - line i ppf "Pexp_newtype \"%s\"\n" s; - expression i ppf e | Texp_pack me -> line i ppf "Pexp_pack"; module_expr i ppf me diff --git a/typing/typeclass.ml b/typing/typeclass.ml index a6847c64..cae89d4d 100644 --- a/typing/typeclass.ml +++ b/typing/typeclass.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: typeclass.ml 12520 2012-05-31 07:41:37Z garrigue $ *) +(* $Id: typeclass.ml 12616 2012-06-19 10:51:33Z garrigue $ *) open Misc open Parsetree @@ -343,12 +343,13 @@ let type_constraint val_env sty sty' loc = end; (cty, cty') -let mkpat d = { ppat_desc = d; ppat_loc = Location.none } -let make_method cl_num expr = +let make_method self_loc cl_num expr = + let mkpat d = { ppat_desc = d; ppat_loc = self_loc } in + let mkid s = mkloc s self_loc in { pexp_desc = Pexp_function ("", None, - [mkpat (Ppat_alias (mkpat(Ppat_var (mknoloc "self-*")), - mknoloc ("self-" ^ cl_num))), + [mkpat (Ppat_alias (mkpat (Ppat_var (mkid "self-*")), + mkid ("self-" ^ cl_num))), expr]); pexp_loc = expr.pexp_loc } @@ -492,7 +493,7 @@ let class_type env scty = (*******************************) -let rec class_field cl_num self_type meths vars +let rec class_field self_loc cl_num self_type meths vars (val_env, met_env, par_env, fields, concr_meths, warn_vals, inher) cf = let loc = cf.pcf_loc in @@ -630,7 +631,7 @@ let rec class_field cl_num self_type meths vars with Ctype.Unify trace -> raise(Error(loc, Field_type_mismatch ("method", lab.txt, trace))) end; - let meth_expr = make_method cl_num expr in + let meth_expr = make_method self_loc cl_num expr in (* backup variables for Pexp_override *) let vars_local = !vars in @@ -657,7 +658,7 @@ let rec class_field cl_num self_type meths vars concr_meths, warn_vals, inher) | Pcf_init expr -> - let expr = make_method cl_num expr in + let expr = make_method self_loc cl_num expr in let vars_local = !vars in let field = lazy begin @@ -678,6 +679,9 @@ and class_structure cl_num final val_env met_env loc (* Environment for substructures *) let par_env = met_env in + (* Location of self. Used for locations of self arguments *) + let self_loc = {spat.ppat_loc with Location.loc_ghost = true} in + (* Self type, with a dummy method preventing it from being closed/escaped. *) let self_type = Ctype.newvar () in Ctype.unify val_env @@ -718,7 +722,7 @@ and class_structure cl_num final val_env met_env loc (* Typing of class fields *) let (_, _, _, fields, concr_meths, _, inher) = - List.fold_left (class_field cl_num self_type meths vars) + List.fold_left (class_field self_loc cl_num self_type meths vars) (val_env, meth_env, par_env, [], Concr.empty, Concr.empty, []) str in diff --git a/typing/typecore.ml b/typing/typecore.ml index 81baa2bd..12262788 100644 --- a/typing/typecore.ml +++ b/typing/typecore.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: typecore.ml 12536 2012-06-01 08:08:53Z garrigue $ *) +(* $Id: typecore.ml 12726 2012-07-18 03:34:36Z garrigue $ *) (* Typechecking for the core language *) @@ -330,7 +330,7 @@ let finalize_variant pat = begin match opat with None -> assert false | Some pat -> List.iter (unify_pat pat.pat_env pat) (ty::tl) end - | Reither (c, l, true, e) when not row.row_fixed -> + | Reither (c, l, true, e) when not (row_fixed row) -> set_row_field e (Reither (c, [], false, ref None)) | _ -> () end; @@ -526,7 +526,7 @@ let rec find_record_qual = function | ({ txt = Longident.Ldot (modname, _) }, _) :: _ -> Some modname | _ :: rest -> find_record_qual rest -let type_label_a_list ?labels env loc type_lbl_a lid_a_list = +let type_label_a_list ?labels env type_lbl_a lid_a_list = let record_qual = find_record_qual lid_a_list in let lbl_a_list = List.map @@ -536,9 +536,9 @@ let type_label_a_list ?labels env loc type_lbl_a lid_a_list = Longident.Lident s, Some labels, _ when Hashtbl.mem labels s -> (Hashtbl.find labels s : Path.t * Types.label_description) | Longident.Lident s, _, Some modname -> - Typetexp.find_label env loc (Longident.Ldot (modname, s)) + Typetexp.find_label env lid.loc (Longident.Ldot (modname, s)) | _ -> - Typetexp.find_label env loc lid.txt + Typetexp.find_label env lid.loc lid.txt in (path, lid, label, a) ) lid_a_list in (* Invariant: records are sorted in the typed tree *) @@ -764,7 +764,7 @@ let rec type_pat ~constrs ~labels ~no_existentials ~mode ~env sp expected_ty = (label_path, label_lid, label, arg) in let lbl_pat_list = - type_label_a_list ?labels !env loc type_label_pat lid_sp_list in + type_label_a_list ?labels !env type_label_pat lid_sp_list in check_recordpat_labels loc lbl_pat_list closed; rp { pat_desc = Tpat_record (lbl_pat_list, closed); @@ -994,9 +994,6 @@ let rec is_nonexpansive exp = match exp.exp_desc with Texp_ident(_,_,_) -> true | Texp_constant _ -> true - | Texp_poly (e, _) - | Texp_newtype (_, e) - -> is_nonexpansive e | Texp_let(rec_flag, pat_exp_list, body) -> List.for_all (fun (pat, exp) -> is_nonexpansive exp) pat_exp_list && is_nonexpansive body @@ -1753,7 +1750,7 @@ and type_expect ?in_function env sexp ty_expected = end | Pexp_record(lid_sexp_list, opt_sexp) -> let lbl_exp_list = - type_label_a_list env loc (type_label_exp true env loc ty_expected) + type_label_a_list env (type_label_exp true env loc ty_expected) lid_sexp_list in let rec check_duplicates seen_pos lid_sexp lbl_exp = match (lid_sexp, lbl_exp) with @@ -2247,7 +2244,7 @@ and type_expect ?in_function env sexp ty_expected = match (expand_head env ty).desc with Tpoly (ty', []) -> let exp = type_expect env sbody ty' in - re { exp with exp_type = instance env ty } + { exp with exp_type = instance env ty } | Tpoly (ty', tl) -> (* One more level to generalize locally *) begin_def (); @@ -2260,16 +2257,19 @@ and type_expect ?in_function env sexp ty_expected = let exp = type_expect env sbody ty'' in end_def (); check_univars env false "method" exp ty_expected vars; - re { exp with exp_type = instance env ty } + { exp with exp_type = instance env ty } | Tvar _ -> let exp = type_exp env sbody in let exp = {exp with exp_type = newty (Tpoly (exp.exp_type, []))} in unify_exp env exp ty; - re exp + exp | _ -> assert false in - re { exp with exp_desc = Texp_poly(exp, cty) } + re { exp with exp_extra = (Texp_poly cty, loc) :: exp.exp_extra } | Pexp_newtype(name, sbody) -> + let ty = newvar () in + (* remember original level *) + begin_def (); (* Create a fake abstract type declaration for name. *) let level = get_current_level () in let decl = { @@ -2283,9 +2283,6 @@ and type_expect ?in_function env sexp ty_expected = type_loc = loc; } in - let ty = newvar () in - (* remember original level *) - begin_def (); Ident.set_current_time ty.level; let (id, new_env) = Env.enter_type name decl env in Ctype.init_def(Ident.current_time()); @@ -2312,7 +2309,8 @@ and type_expect ?in_function env sexp ty_expected = (* non-expansive if the body is non-expansive, so we don't introduce any new extra node in the typed AST. *) - rue { body with exp_loc = sexp.pexp_loc; exp_type = ety } + rue { body with exp_loc = loc; exp_type = ety; + exp_extra = (Texp_newtype name, loc) :: body.exp_extra } | Pexp_pack m -> let (p, nl, tl) = match Ctype.expand_head env (instance env ty_expected) with @@ -2357,7 +2355,7 @@ and type_label_exp create env loc ty_expected begin try unify env (instance_def ty_res) (instance env ty_expected) with Unify trace -> - raise(Error(loc , Label_mismatch(lid_of_label label, trace))) + raise (Error(lid.loc, Label_mismatch(lid_of_label label, trace))) end; (* Instantiate so that we can generalize internal nodes *) let ty_arg = instance_def ty_arg in @@ -2367,8 +2365,10 @@ and type_label_exp create env loc ty_expected generalize_structure ty_arg end; if label.lbl_private = Private then - raise(Error(loc, if create then Private_type ty_expected - else Private_label (lid_of_label label, ty_expected))); + if create then + raise (Error(loc, Private_type ty_expected)) + else + raise (Error(lid.loc, Private_label(lid_of_label label, ty_expected))); let arg = let snap = if vars = [] then None else Some (Btype.snapshot ()) in let arg = type_argument env sarg ty_arg (instance env ty_arg) in diff --git a/typing/typedecl.ml b/typing/typedecl.ml index cfc3d568..37ff396a 100644 --- a/typing/typedecl.ml +++ b/typing/typedecl.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: typedecl.ml 12550 2012-06-04 10:02:17Z frisch $ *) +(* $Id: typedecl.ml 12609 2012-06-14 10:47:30Z garrigue $ *) (**** Typing of type definitions ****) @@ -402,12 +402,25 @@ let check_abbrev env (_, sdecl) (id, decl) = end | _ -> () +(* Check that recursion is well-founded *) + +let check_well_founded env loc path decl = + Misc.may + (fun body -> + try Ctype.correct_abbrev env path decl.type_params body with + | Ctype.Recursive_abbrev -> + raise(Error(loc, Recursive_abbrev (Path.name path))) + | Ctype.Unify trace -> raise(Error(loc, Type_clash trace))) + decl.type_manifest + (* Check for ill-defined abbrevs *) let check_recursion env loc path decl to_check = (* to_check is true for potentially mutually recursive paths. (path, decl) is the type declaration to be checked. *) + if decl.type_params = [] then () else + let visited = ref [] in let rec check_regular cpath args prev_exp ty = @@ -450,22 +463,13 @@ let check_recursion env loc path decl to_check = Btype.iter_type_expr (check_regular cpath args prev_exp) ty end in - match decl.type_manifest with - | None -> () - | Some body -> - (* Check that recursion is well-founded *) - begin try - Ctype.correct_abbrev env path decl.type_params body - with Ctype.Recursive_abbrev -> - raise(Error(loc, Recursive_abbrev (Path.name path))) - | Ctype.Unify trace -> raise(Error(loc, Type_clash trace)) - end; - (* Check that recursion is regular *) - if decl.type_params = [] then () else + Misc.may + (fun body -> let (args, body) = Ctype.instance_parameterized_type ~keep_names:true decl.type_params body in - check_regular path args [] body + check_regular path args [] body) + decl.type_manifest let check_abbrev_recursion env id_loc_list (id, _, tdecl) = let decl = tdecl.typ_type in @@ -830,6 +834,9 @@ let transl_type_decl env name_sdecl_list = List.map2 (fun id (_,sdecl) -> (id, sdecl.ptype_loc)) id_list name_sdecl_list in + List.iter (fun (id, decl) -> + check_well_founded newenv (List.assoc id id_loc_list) (Path.Pident id) decl) + decls; List.iter (check_abbrev_recursion newenv id_loc_list) tdecls; (* Check that all type variable are closed *) List.iter2 @@ -1019,6 +1026,7 @@ let approx_type_decl env name_sdecl_list = let check_recmod_typedecl env loc recmod_ids path decl = (* recmod_ids is the list of recursively-defined module idents. (path, decl) is the type declaration to be checked. *) + check_well_founded env loc path decl; check_recursion env loc path decl (fun path -> List.exists (fun id -> Path.isfree id path) recmod_ids) diff --git a/typing/typedtree.ml b/typing/typedtree.ml index 48c68c98..c3ba3b71 100644 --- a/typing/typedtree.ml +++ b/typing/typedtree.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: typedtree.ml 12520 2012-05-31 07:41:37Z garrigue $ *) +(* $Id: typedtree.ml 12681 2012-07-10 08:33:16Z garrigue $ *) (* Abstract syntax tree after typing *) @@ -61,6 +61,8 @@ and expression = and exp_extra = | Texp_constraint of core_type option * core_type option | Texp_open of Path.t * Longident.t loc * Env.t + | Texp_poly of core_type option + | Texp_newtype of string and expression_desc = Texp_ident of Path.t * Longident.t loc * Types.value_description @@ -98,9 +100,7 @@ and expression_desc = | Texp_assert of expression | Texp_assertfalse | Texp_lazy of expression - | Texp_poly of expression * core_type option | Texp_object of class_structure * string list - | Texp_newtype of string * expression | Texp_pack of module_expr and meth = diff --git a/typing/typedtree.mli b/typing/typedtree.mli index 0a32ba2a..38b5e258 100644 --- a/typing/typedtree.mli +++ b/typing/typedtree.mli @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: typedtree.mli 12521 2012-05-31 07:57:32Z garrigue $ *) +(* $Id: typedtree.mli 12681 2012-07-10 08:33:16Z garrigue $ *) (* Abstract syntax tree after typing *) @@ -60,6 +60,8 @@ and expression = and exp_extra = | Texp_constraint of core_type option * core_type option | Texp_open of Path.t * Longident.t loc * Env.t + | Texp_poly of core_type option + | Texp_newtype of string and expression_desc = Texp_ident of Path.t * Longident.t loc * Types.value_description @@ -97,9 +99,7 @@ and expression_desc = | Texp_assert of expression | Texp_assertfalse | Texp_lazy of expression - | Texp_poly of expression * core_type option | Texp_object of class_structure * string list - | Texp_newtype of string * expression | Texp_pack of module_expr and meth =