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)
. 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.
- 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)
- 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
- 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
- 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
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
- 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
- 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
- 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
- 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
- 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
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"
# #
#########################################################################
-# $Id: Makefile 12511 2012-05-30 13:29:48Z lefessan $
+# $Id: Makefile 12692 2012-07-10 15:20:34Z doligez $
# The main Makefile
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
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
# #
#########################################################################
-# $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
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
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
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 \
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 \
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:
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.
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.
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.
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
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.
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:
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.
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.
------------------------------------------------------------------------------
-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 $
(* *)
(***********************************************************************)
-(* $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 *)
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
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
type kind = Dinfo_call | Dinfo_raise
-type t = {
+type t = private {
dinfo_kind: kind;
dinfo_file: string;
dinfo_line: int;
(* *)
(***********************************************************************)
-(* $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 *)
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 =
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
(* CFI directives *)
let is_cfi_enabled () =
- !Clflags.debug && Config.asm_cfi_supported
+ Config.asm_cfi_supported
let cfi_startproc () =
if is_cfi_enabled () then
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
(* *)
(***********************************************************************)
-(* $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 *)
(* Behavior of division *)
-let division_crashes_on_overflow = false
+let division_crashes_on_overflow = true
(* Operations on addressing modes *)
(* *)
(***********************************************************************)
-(* $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 *)
| 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 =
/* */
/***********************************************************************/
-/* $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 */
#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
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
#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
#define CFI_ENDPROC
#define CFI_ADJUST(n)
#endif
-
+
#if defined(__PIC__) && !defined(SYS_mingw64)
/* Position-independent operations on global variables. */
popq %r11
#else
-
+
/* Non-PIC operations on global variables. Slightly faster. */
#define STORE_VAR(srcreg,dstlabel) \
#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 */
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
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 */
/* 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 */
(* *)
(***********************************************************************)
-(* $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 *)
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 =
(* *)
(***********************************************************************)
-(* $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 *)
(* 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
(* *)
(***********************************************************************)
-(* $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 *)
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;
(* *)
(***********************************************************************)
-(* $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 *)
[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
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
# #
#########################################################################
-# $Id: Makefile 12567 2012-06-04 17:01:09Z doligez $
+# $Id: Makefile 12566 2012-06-04 16:33:59Z doligez $
include Makefile.common
/* */
/***********************************************************************/
-/* $Id: compact.c 12524 2012-05-31 11:50:51Z doligez $ */
+/* $Id: compact.c 12621 2012-06-20 15:39:09Z doligez $ */
#include <string.h>
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
/* 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;
/* */
/***********************************************************************/
-/* $Id: custom.c 11156 2011-07-27 14:17:02Z doligez $ */
+/* $Id: custom.c 12658 2012-07-06 16:44:24Z xleroy $ */
#include <string.h>
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;
/* */
/***********************************************************************/
-/* $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. */
{
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 */
/* */
/***********************************************************************/
-/* $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). */
/* 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;
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);
/* */
/***********************************************************************/
-/* $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). */
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);
/* */
/***********************************************************************/
-/* $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
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;
}
/* */
/***********************************************************************/
-/* $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"
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));
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
/* */
/***********************************************************************/
-/* $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. */
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);
/* */
/***********************************************************************/
-/* $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 <limits.h>
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;
}
}
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;
}
}
/* */
/***********************************************************************/
-/* $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 */
{
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();
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,
/* 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);
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);
/* */
/***********************************************************************/
-/* $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 */
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)
{
{
char * p;
- if (arg[0] == '@') {
- expand_diversion(arg + 1);
- return;
- }
for (p = arg; *p != 0; p++) {
if (*p == '*' || *p == '?') {
expand_pattern(arg);
_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)
{
"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
| <: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 =
| <: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 "@[<hv0>@[<hv2>{%a@]@ }@]" o#record_binding b
| <: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
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"$
;
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
;
print_kind ty2
| ty -> print_kind ppf ty ]
in
- fprintf ppf "@[<2>@[<hv 2>@[%s %t@] =%a@]%a@]" kwd type_defined
- print_types ty print_constraints constraints
+ match ty with
+ [ Otyp_abstract ->
+ fprintf ppf "@[<2>@[<hv 2>@[%s %t@]@]%a@]" kwd type_defined
+ print_constraints constraints
+ | _ ->
+ fprintf ppf "@[<2>@[<hv 2>@[%s %t@] =%a@]%a@]" kwd type_defined
+ print_types ty print_constraints constraints ]
;
(* Phrases *)
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 =
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')
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))
| _ ->
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
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
"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
| 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 "@[<hv0>@[<hv2>{%a@]@ }@]" o#record_binding b
| 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
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 ->
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")
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")
[ (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)
(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" ],
-.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
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
# #
#########################################################################
-# $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
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*)
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;;
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
(* *)
(***********************************************************************)
-(* $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. *)
(* *)
(***********************************************************************)
-(* $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 *)
(* 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
(* *)
(***********************************************************************)
-(* $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 *)
module EvalPath =
struct
- type value = Debugcom.Remote_value.t
+ type valu = Debugcom.Remote_value.t
exception Error
let rec eval_path = function
Pident id ->
;(* *)
;(***********************************************************************)
-;(* $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.
. 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)))
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)
))
| 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
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);;
#(* *)
#(***********************************************************************)
-# $Id: Makefile 12511 2012-05-30 13:29:48Z lefessan $
+# $Id: Makefile 12707 2012-07-13 11:23:13Z doligez $
include ../config/Makefile
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
generatorsopt: $(GENERATORS_CMXS)
debug:
- make OCAMLPP=""
+ $(MAKE) OCAMLPP=""
$(OCAMLDOC): $(EXECMOFILES)
$(OCAMLC) -o $@ -linkall unix.cma str.cma dynlink.cma $(LINKFLAGS) $(OCAMLCMOFILES) $(EXECMOFILES)
$(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
#(* *)
#(***********************************************************************)
-# $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
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)
(* *)
(***********************************************************************)
-(* $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. *)
| 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)
(* *)
(***********************************************************************)
-(* $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. *)
(** 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
(* *)
(***********************************************************************)
-(* $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. *)
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
(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 =
| 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 ->
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
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)
)
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
| 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
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
(* 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 ->
(* *)
(***********************************************************************)
-(* $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.*)
(** 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
/* */
/***********************************************************************/
-/* $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 <stddef.h>
#include <string.h>
(* *)
(*************************************************************************)
-(* $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
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
/* */
/***********************************************************************/
-/* $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 <wtypes.h>
# #
#########################################################################
-# $Id: Makefile 11156 2011-07-27 14:17:02Z doligez $
+# $Id: Makefile 12585 2012-06-08 11:35:37Z xleroy $
include ../../config/Makefile
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) \
/* */
/***********************************************************************/
-/* $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 */
| 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
{ 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)) }
| 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 */
(* *)
(***********************************************************************)
-(* $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. *)
*)
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
*)
(* *)
(***********************************************************************)
-(* $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
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 }
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;
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 =
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
(* 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 *)
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"
-# $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 ''`
-# $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)
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;
@$(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
-# $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)
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
BASEDIR=../..
+
CC=$(NATIVECC)
CFLAGS=$(NATIVECCCOMPOPTS) -g
@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
/* */
/***********************************************************************/
-/* $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
/* */
/***********************************************************************/
-/* $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
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
--- /dev/null
+BASEDIR=../..
+MODULES=testing
+include $(BASEDIR)/makefiles/Makefile.several
+include $(BASEDIR)/makefiles/Makefile.common
--- /dev/null
+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);
+ ()
--- /dev/null
+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.
-sort test1.result | diff -q test1.reference -
+LC_ALL=C sort test1.result | diff -q test1.reference -
-sort -u test4.result | diff -q test4.reference -
+LC_ALL=C sort -u test4.result | diff -q test4.reference -
-sort -u test5.result | diff -q test5.reference -
+LC_ALL=C sort -u test5.result | diff -q test5.reference -
-sort -u test6.result | diff -q test6.reference -
+LC_ALL=C sort -u test6.result | diff -q test6.reference -
-sort testA.result | diff -q testA.reference -
+LC_ALL=C sort testA.result | diff -q testA.reference -
-sort testexit.result | diff -q testexit.reference -
+LC_ALL=C sort testexit.result | diff -q testexit.reference -
--- /dev/null
+MAIN_MODULE=pr5233
+
+include ../../../makefiles/Makefile.one
+include ../../../makefiles/Makefile.common
--- /dev/null
+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);;
--- /dev/null
+checking... value found / testing... ok
+checking... no value
--- /dev/null
+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
+;;
--- /dev/null
+
+# 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 = <fun>
+# 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 = <fun>
+# type _ linkp = Nonlink : [ `Nonlink ] linkp | Maylink : inkind linkp
+# val inlineseq_from_astseq : ast_t list -> inkind inline_t list = <fun>
+# 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
+#
--- /dev/null
+
+# 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 = <fun>
+# 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 = <fun>
+# type _ linkp = Nonlink : [ `Nonlink ] linkp | Maylink : inkind linkp
+# val inlineseq_from_astseq : ast_t list -> inkind inline_t list = <fun>
+# 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
+#
--- /dev/null
+BASEDIR=../..
+include $(BASEDIR)/makefiles/Makefile.toplevel
+include $(BASEDIR)/makefiles/Makefile.common
+
--- /dev/null
+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;;
--- /dev/null
+
+# 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 = <fun>
+#
--- /dev/null
+(* 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;;
--- /dev/null
+
+# 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
+#
-#MODULES=
BASEDIR=../..
-MAIN_MODULE=newtype
-ADD_COMPFLAGS=-w a
-
-include $(BASEDIR)/makefiles/Makefile.one
+include $(BASEDIR)/makefiles/Makefile.toplevel
include $(BASEDIR)/makefiles/Makefile.common
+
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
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 *)
--- /dev/null
+
+# val property : unit -> ('a -> exn) * (exn -> 'a option) = <fun>
+# false
+true
+true
+false
+# val sort_uniq : ('a -> 'a -> int) -> 'a list -> 'a list = <fun>
+# 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
+#
+++ /dev/null
-false
-true
-true
-false
-abc,xyz
--- /dev/null
+#!/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
(* *)
(***********************************************************************)
-(* $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
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;
| 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
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
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
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,
"<dir> Add <dir> to the list of include directories";
"-impl", Arg.String (file_dependencies_as ML),
- "<f> Process <f> as a .ml file";
+ "<f> Process <f> as a .ml file";
"-intf", Arg.String (file_dependencies_as MLI),
- "<f> Process <f> as a .mli file";
+ "<f> Process <f> as a .mli file";
"-ml-synonym", Arg.String(add_to_synonym_list ml_synonyms),
- "<e> Consider <e> as a synonym of the .ml extension";
+ "<e> Consider <e> as a synonym of the .ml extension";
"-mli-synonym", Arg.String(add_to_synonym_list mli_synonyms),
- "<e> Consider <e> as a synonym of the .mli extension";
- "-sort", Arg.Set sort_files,
- " Sort files according to their dependencies";
+ "<e> Consider <e> 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),
- "<cmd> Pipe sources through preprocessor <cmd>";
+ "<cmd> Pipe sources through preprocessor <cmd>";
"-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)
(* *)
(***********************************************************************)
-(* $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
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")
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
(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
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
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;
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
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,
(* *)
(***********************************************************************)
-(* $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 *)
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 =
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
(* *)
(***********************************************************************)
-(* $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 *)
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 =
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)
(* *)
(***********************************************************************)
-(* $Id: topdirs.ml 12184 2012-02-23 19:54:44Z doligez $ *)
+(* $Id: topdirs.ml 12661 2012-07-07 11:41:17Z scherer $ *)
(* Toplevel directives *)
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
(* *)
(***********************************************************************)
-(* $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. *)
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
(* *)
(***********************************************************************)
-(* $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 *)
(* 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)
(* *)
(***********************************************************************)
-(* $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 *)
| {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 &&
(* *)
(***********************************************************************)
-(* $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 *)
(* 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
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
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)
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 =
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 []
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
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 [];
cmt_initial_env : Env.t;
cmt_imports : (string * Digest.t) list;
cmt_interface_digest : Digest.t option;
+ cmt_use_summaries : bool;
}
type error =
(* *)
(***********************************************************************)
-(* $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 *)
| (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;
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 =
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
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;
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
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)))
| 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 ->
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;
| 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'))
(* *)
(***********************************************************************)
-(* $Id: env.ml 12542 2012-06-01 14:06:31Z frisch $ *)
+(* $Id: env.ml 12706 2012-07-13 08:49:06Z lefessan $ *)
(* Environment handling *)
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:
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;
}
(* 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
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;
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) ->
| 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;
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
(* 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 *)
(* *)
(***********************************************************************)
-(* $Id: env.mli 12542 2012-06-01 14:06:31Z frisch $ *)
+(* $Id: env.mli 12706 2012-07-13 08:49:06Z lefessan $ *)
(* Environment handling *)
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 =
(* *)
(***********************************************************************)
-(* $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. *)
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) ->
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
| _ -> ()
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;
| 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
(* *)
(***********************************************************************)
-(* $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
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 }
(*******************************)
-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
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
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
(* 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
(* 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
(* *)
(***********************************************************************)
-(* $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 *)
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;
| ({ 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
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 *)
(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);
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
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
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 ();
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 = {
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());
(* 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
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
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
(* *)
(***********************************************************************)
-(* $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 ****)
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 =
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
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
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)
(* *)
(***********************************************************************)
-(* $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 *)
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
| 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 =
(* *)
(***********************************************************************)
-(* $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 *)
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
| 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 =
projects / ocaml.git / commitdiff