Skip to content

Instantly share code, notes, and snippets.

@yallop

yallop/ber-n102.patch

Created January 10, 2015 16:52
Show Gist options
  • Star 1 You must be signed in to star a gist
  • Fork 0 You must be signed in to fork a gist
  • Save yallop/7d7e471ece10f5893642 to your computer and use it in GitHub Desktop.
Save yallop/7d7e471ece10f5893642 to your computer and use it in GitHub Desktop.
Download ZIP
BER n102 patch
Raw
ber-n102.patch
diff -Naur ocaml-4.02.1/.depend ocaml-ber-n102/.depend
--- ocaml-4.02.1/.depend 2015-01-10 16:27:54.270865651 +0000
+++ ocaml-ber-n102/.depend 2015-01-10 16:27:06.936030975 +0000
@@ -122,6 +122,9 @@
typing/stypes.cmi : typing/typedtree.cmi parsing/location.cmi \
typing/annot.cmi
typing/subst.cmi : typing/types.cmi typing/path.cmi typing/ident.cmi
+typing/trx.cmi : typing/types.cmi typing/typedtree.cmi parsing/parsetree.cmi \
+ parsing/longident.cmi parsing/location.cmi typing/env.cmi \
+ parsing/asttypes.cmi
typing/typeclass.cmi : typing/types.cmi typing/typedtree.cmi \
parsing/parsetree.cmi parsing/longident.cmi parsing/location.cmi \
typing/ident.cmi typing/env.cmi typing/ctype.cmi parsing/asttypes.cmi
@@ -280,6 +283,18 @@
typing/subst.cmx : typing/types.cmx utils/tbl.cmx typing/path.cmx \
utils/misc.cmx parsing/location.cmx typing/ident.cmx utils/clflags.cmx \
typing/btype.cmx parsing/ast_mapper.cmx typing/subst.cmi
+typing/trx.cmo : utils/warnings.cmi typing/types.cmi typing/typedtree.cmi \
+ typing/printtyp.cmi typing/predef.cmi typing/path.cmi \
+ parsing/parsetree.cmi utils/misc.cmi parsing/longident.cmi \
+ parsing/location.cmi typing/ident.cmi typing/env.cmi typing/ctype.cmi \
+ typing/btype.cmi parsing/asttypes.cmi parsing/ast_helper.cmi \
+ typing/trx.cmi
+typing/trx.cmx : utils/warnings.cmx typing/types.cmx typing/typedtree.cmx \
+ typing/printtyp.cmx typing/predef.cmx typing/path.cmx \
+ parsing/parsetree.cmi utils/misc.cmx parsing/longident.cmx \
+ parsing/location.cmx typing/ident.cmx typing/env.cmx typing/ctype.cmx \
+ typing/btype.cmx parsing/asttypes.cmi parsing/ast_helper.cmx \
+ typing/trx.cmi
typing/typeclass.cmo : utils/warnings.cmi typing/typetexp.cmi \
typing/types.cmi typing/typedtree.cmi typing/typedecl.cmi \
typing/typecore.cmi parsing/syntaxerr.cmi typing/subst.cmi \
@@ -299,23 +314,25 @@
utils/clflags.cmx typing/btype.cmx parsing/asttypes.cmi \
parsing/ast_helper.cmx typing/typeclass.cmi
typing/typecore.cmo : utils/warnings.cmi typing/typetexp.cmi \
- typing/types.cmi typing/typedtree.cmi parsing/syntaxerr.cmi \
- typing/subst.cmi typing/stypes.cmi typing/printtyp.cmi \
- typing/primitive.cmi typing/predef.cmi typing/path.cmi \
- parsing/parsetree.cmi typing/parmatch.cmi typing/oprint.cmi \
- utils/misc.cmi parsing/longident.cmi parsing/location.cmi \
- typing/ident.cmi typing/env.cmi typing/ctype.cmi typing/cmt_format.cmi \
- utils/clflags.cmi typing/btype.cmi parsing/asttypes.cmi \
- parsing/ast_helper.cmi typing/annot.cmi typing/typecore.cmi
+ typing/types.cmi typing/typedtree.cmi typing/trx.cmi \
+ parsing/syntaxerr.cmi typing/subst.cmi typing/stypes.cmi \
+ typing/printtyp.cmi typing/primitive.cmi typing/predef.cmi \
+ typing/path.cmi parsing/parsetree.cmi typing/parmatch.cmi \
+ typing/oprint.cmi utils/misc.cmi parsing/longident.cmi \
+ parsing/location.cmi typing/ident.cmi typing/env.cmi typing/ctype.cmi \
+ typing/cmt_format.cmi utils/clflags.cmi typing/btype.cmi \
+ parsing/asttypes.cmi parsing/ast_helper.cmi typing/annot.cmi \
+ typing/typecore.cmi
typing/typecore.cmx : utils/warnings.cmx typing/typetexp.cmx \
- typing/types.cmx typing/typedtree.cmx parsing/syntaxerr.cmx \
- typing/subst.cmx typing/stypes.cmx typing/printtyp.cmx \
- typing/primitive.cmx typing/predef.cmx typing/path.cmx \
- parsing/parsetree.cmi typing/parmatch.cmx typing/oprint.cmx \
- utils/misc.cmx parsing/longident.cmx parsing/location.cmx \
- typing/ident.cmx typing/env.cmx typing/ctype.cmx typing/cmt_format.cmx \
- utils/clflags.cmx typing/btype.cmx parsing/asttypes.cmi \
- parsing/ast_helper.cmx typing/annot.cmi typing/typecore.cmi
+ typing/types.cmx typing/typedtree.cmx typing/trx.cmx \
+ parsing/syntaxerr.cmx typing/subst.cmx typing/stypes.cmx \
+ typing/printtyp.cmx typing/primitive.cmx typing/predef.cmx \
+ typing/path.cmx parsing/parsetree.cmi typing/parmatch.cmx \
+ typing/oprint.cmx utils/misc.cmx parsing/longident.cmx \
+ parsing/location.cmx typing/ident.cmx typing/env.cmx typing/ctype.cmx \
+ typing/cmt_format.cmx utils/clflags.cmx typing/btype.cmx \
+ parsing/asttypes.cmi parsing/ast_helper.cmx typing/annot.cmi \
+ typing/typecore.cmi
typing/typedecl.cmo : utils/warnings.cmi typing/typetexp.cmi \
typing/types.cmi typing/typedtree.cmi parsing/syntaxerr.cmi \
typing/subst.cmi typing/printtyp.cmi typing/primitive.cmi \
diff -Naur ocaml-4.02.1/Makefile ocaml-ber-n102/Makefile
--- ocaml-4.02.1/Makefile 2015-01-10 16:27:54.270865651 +0000
+++ ocaml-ber-n102/Makefile 2015-01-10 16:27:06.936030975 +0000
@@ -20,6 +20,9 @@
COMPFLAGS=-strict-sequence -w +33..39+48 -warn-error A -bin-annot \
-safe-string $(INCLUDES)
LINKFLAGS=
+# For debugging
+# COMPFLAGS=-warn-error A -g $(INCLUDES) # NNN
+# LINKFLAGS=-g #NNN
CAMLYACC=boot/ocamlyacc
YACCFLAGS=-v
@@ -49,6 +52,7 @@
parsing/pprintast.cmo \
parsing/ast_mapper.cmo
+# NNN (trx)
TYPING=typing/ident.cmo typing/path.cmo \
typing/primitive.cmo typing/types.cmo \
typing/btype.cmo typing/oprint.cmo \
@@ -59,6 +63,7 @@
typing/mtype.cmo typing/envaux.cmo typing/includecore.cmo \
typing/typedtreeIter.cmo typing/typedtreeMap.cmo typing/cmt_format.cmo \
typing/includemod.cmo typing/typetexp.cmo typing/parmatch.cmo \
+ typing/trx.cmo \
typing/stypes.cmo typing/typecore.cmo \
typing/typedecl.cmo typing/typeclass.cmo \
typing/typemod.cmo
@@ -130,6 +135,8 @@
$(MAKE) otherlibraries $(OCAMLBUILDBYTE) $(WITH_DEBUGGER) \
$(WITH_OCAMLDOC)
+# NNN make all && (cd metalib && make clean all) && (make install; cd metalib && make install)
+
# Compile everything the first time
world:
$(MAKE) coldstart
@@ -325,6 +332,13 @@
$(INSTALL_COMPLIBDIR)
cp expunge $(INSTALL_LIBDIR)/expunge$(EXE)
cp toplevel/topdirs.cmi $(INSTALL_LIBDIR)
+# NNN typing/trx.ml needs its own interface (since it looks up identifiers
+# in itself)
+# Although typing/trx.cmi is already copied, see above, it is copied
+# into $((COMPLIBDIR). We need trx.cmi in the standard .cmi search path.
+ cp typing/trx.cmi $(INSTALL_LIBDIR)
+# BTW, trx.cmo is part of ocamlcommon.cma
+# NNN end
cd tools; $(MAKE) install
-cd man; $(MAKE) install
for i in $(OTHERLIBRARIES); do \
@@ -744,7 +758,7 @@
partialclean::
cd ocamldoc && $(MAKE) clean
-alldepend::
+alldepen1d::
cd ocamldoc && $(MAKE) depend
# The extra libraries
diff -Naur ocaml-4.02.1/metalib/berstart.ml ocaml-ber-n102/metalib/berstart.ml
--- ocaml-4.02.1/metalib/berstart.ml 1970-01-01 01:00:00.000000000 +0100
+++ ocaml-ber-n102/metalib/berstart.ml 2015-01-10 16:27:06.936030975 +0000
@@ -0,0 +1,21 @@
+(*
+ To `run' the code we use toplevel facilities.
+ If we invoke BER MetaOcaml top level, then Toplevel.topstart() will
+ initalialize the top level.
+ If we execute a byte-compiled executable, we link with
+ the top-level library. But we need initialize it first.
+ This is the job of the current file.
+
+ This file must be linked in *before* the first user executable.
+
+ The present code roughly do the same steps OCaml top level does
+ when executing a script.
+ See Toplevel.topmain
+*)
+
+let () =
+ Toploop.set_paths ();
+ Compmisc.init_path true;
+ Toploop.initialize_toplevel_env ()
+ (* toplevel_env := Compile.initial_env();
+ *)
diff -Naur ocaml-4.02.1/metalib/bertop.ml ocaml-ber-n102/metalib/bertop.ml
--- ocaml-4.02.1/metalib/bertop.ml 1970-01-01 01:00:00.000000000 +0100
+++ ocaml-ber-n102/metalib/bertop.ml 2015-01-10 16:27:06.936030975 +0000
@@ -0,0 +1,26 @@
+(* `Plugin' for the OCaml top-level *)
+open Longident
+
+(* Install printers for code values *)
+let install_printers () =
+ Topdirs.dir_install_printer Format.std_formatter
+ (Ldot(Lident "Print_code", "print_code"));
+ Topdirs.dir_install_printer Format.std_formatter
+ (Ldot(Lident "Print_code", "print_closed_code"))
+
+(* Initialization function *)
+
+let initialize () =
+ Printf.printf "BER MetaOCaml toplevel, version %s\n" Trx.meta_version;
+ install_printers ()
+
+(* Hook up to the top level *)
+let () =
+Toploop.toplevel_startup_hook :=
+ let old_hook = !Toploop.toplevel_startup_hook in
+ fun () ->
+ begin
+ initialize ();
+ old_hook ()
+ end
+
diff -Naur ocaml-4.02.1/metalib/build_patch.sh ocaml-ber-n102/metalib/build_patch.sh
--- ocaml-4.02.1/metalib/build_patch.sh 1970-01-01 01:00:00.000000000 +0100
+++ ocaml-ber-n102/metalib/build_patch.sh 2015-01-10 16:27:06.936030975 +0000
@@ -0,0 +1,21 @@
+#!/bin/sh
+# Building the patch set
+# build_patch
+# This auxiliary file builds the patch set using the internal
+# GIT repository. The patch set is written into the standard output.
+
+cd ..
+
+#git diff 327f91b41f16b223c783070fa44058c5b1db8804 --
+git diff 4.02 -- \
+./.depend \
+./Makefile \
+./parsing/lexer.mll \
+./parsing/parser.mly \
+./parsing/pprintast.ml \
+./typing/predef.ml \
+./typing/predef.mli \
+./typing/typecore.ml
+
+# svn diff -r5522 \
+# tools/addlabels.ml \
diff -Naur ocaml-4.02.1/metalib/ChangeLog ocaml-ber-n102/metalib/ChangeLog
--- ocaml-4.02.1/metalib/ChangeLog 1970-01-01 01:00:00.000000000 +0100
+++ ocaml-ber-n102/metalib/ChangeLog 2015-01-10 16:27:06.936030975 +0000
@@ -0,0 +1,97 @@
+December 31, 2014
+ Release N102
+ - There is no longer a separate Typedtree traversal pass, after
+ the type checking, to translate brackets and escapes. The
+ translation is done right after the type-checking of the 0-level
+ bracket. That means that for staging-annotation-free code,
+ MetaOCaml has no substantial overhead.
+ - Use attributes for brackets, escapes and CSP (and internally
+ for levels and inexpansiveness). Much fewer OCaml files are
+ modified.
+ - New function Runcode.typecheck_code for the benefit of offshoring
+ - New function Runcode.add_search_path to add a directory to
+ the search path for .cmi/.cmo files -- report by Nicolas Ojeda Bar
+ - Better handling of CSP. For simple cases, there are no longer
+ any serialization problems.
+ - Overall better printing, of CSP, code and error messages.
+ - Overall, more uniform, better-factored code.
+ - metaocamlc is now a simple .c file; it adds compiler-libs only
+ in the case when the executable is built. Otherwise, we may end up
+ with the duplicate libraries.
+
+April 24, 2014
+ Fixed the problem noted by Jun Inoue in toplevel MetaOCaml.
+ If the first Runcode.run is used after a type declaration,
+ the defined type is considered locally scoped, which causes
+ type checking errors or assettion faliures in typechecking.
+ Preparing the environment for Runcode.run has a side-effect,
+ of corrupting Ident timestamps. The timestamps are preserved now.
+
+November 26, 2013
+ Release N101
+ Removed environment classifiers.
+ Syntax .! is replaced with the ordinary prefix operation
+ !. (alias run) in the module Runcode. Runcode.run is an
+ ordinary function, and is not part of the MetaOCaml kernel.
+ New API for running code, encouraging the development of new ways
+ to execute code values (see metalib/runcode.mli).
+ BER N101 is binary compatible with OCaml 4.01. Building it
+ no longer involves bootstrapping.
+ Printing code is now part of OCaml (Pprintast, which was influenced by
+ MetaOCaml).
+ Scope-extrusion check works with delimited control.
+ Added a test for the well-formedness of recursive let.
+ Faster generation of code (especially for functions and nonbinding
+ functions).
+ More precise tracking of free variables and reporting of scope
+ extrusion.
+
+February 20, 2013
+ Re-enabled ocamlbuild.byte target in the Makefile, so to
+ to build ocamlbuild as part of the make all.
+ A small fix to permit compiling ocamlopt. Although at present,
+ ocamlopt can't compile code with brackets, it can compile
+ the regular OCaml code. In addition, it supports let!.
+ Thanks to Bob Zhang for suggestions.
+
+January 30, 2013
+ Rewritten trx.ml. Release N100.
+
+January 12, 2013
+ Importing the pretty-printing of code, greatly improved by Jacques
+ Carette.
+
+January 7-12, 2013
+ Beginning the port to OCaml 4.00.1. The basic changes to OCaml
+ are done. Started work on re-writing trx.ml
+
+December 28, 2012
+ Version N004 released
+
+November 8, 2012
+ Eliminating val_level from value_desc. Introducing Env map stage
+ to map an identifier to its stage, if not zero. Several
+ OCaml modules no longer have to be patched.
+ Simplified CSP code, removed a few patches from typecore.
+ SCP now carries strings, native_int, int32, int64 as
+ literal constants. Identifiers in List module are carried
+ by reference.
+
+October 4, 2012
+ Jacques Carette has committed Alain Frisch's patch implementing
+ the let! form proposed by Nicolas Pouillard for monadic
+ programming in Ocaml.
+ http://pauillac.inria.fr/~protzenk/let-bang.html
+ See metalib/test/pythagorian_triples.ml for an example.
+
+January 3, 2011
+ Added metaocamlmktop
+
+December 2010
+ Patch from Fabrice Le Fessant to remove functional values
+ from typing Env. See entry May 5, 2010 in Problems.txt.
+ Generic printing is now part of BER MetaOCaml.
+
+March 1, 2010
+ Version N002 released, based on OCaml 3.11
+
diff -Naur ocaml-4.02.1/metalib/cycle.h ocaml-ber-n102/metalib/cycle.h
--- ocaml-4.02.1/metalib/cycle.h 1970-01-01 01:00:00.000000000 +0100
+++ ocaml-ber-n102/metalib/cycle.h 2015-01-10 16:27:06.936030975 +0000
@@ -0,0 +1,434 @@
+/*
+ * Copyright (c) 2003 Matteo Frigo
+ * Copyright (c) 2003 Massachusetts Institute of Technology
+ *
+ * Permission is hereby granted, free of charge, to any person obtaining
+ * a copy of this software and associated documentation files (the
+ * "Software"), to deal in the Software without restriction, including
+ * without limitation the rights to use, copy, modify, merge, publish,
+ * distribute, sublicense, and/or sell copies of the Software, and to
+ * permit persons to whom the Software is furnished to do so, subject to
+ * the following conditions:
+ *
+ * The above copyright notice and this permission notice shall be
+ * included in all copies or substantial portions of the Software.
+ *
+ * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+ * EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+ * MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+ * NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+ * LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+ * OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+ * WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ *
+ */
+
+/* $Id$ */
+
+/* machine-dependent cycle counters code. Needs to be inlined. */
+
+/***************************************************************************/
+/* To use the cycle counters in your code, simply #include "cycle.h" (this
+ file), and then use the functions/macros:
+
+ ticks getticks(void);
+
+ ticks is an opaque typedef defined below, representing the current time.
+ You extract the elapsed time between two calls to gettick() via:
+
+ double elapsed(ticks t1, ticks t0);
+
+ which returns a double-precision variable in arbitrary units. You
+ are not expected to convert this into human units like seconds; it
+ is intended only for *comparisons* of time intervals.
+
+ (In order to use some of the OS-dependent timer routines like
+ Solaris' gethrtime, you need to paste the autoconf snippet below
+ into your configure.ac file and #include "config.h" before cycle.h,
+ or define the relevant macros manually if you are not using autoconf.)
+*/
+
+/***************************************************************************/
+/* This file uses macros like HAVE_GETHRTIME that are assumed to be
+ defined according to whether the corresponding function/type/header
+ is available on your system. The necessary macros are most
+ conveniently defined if you are using GNU autoconf, via the tests:
+
+ dnl ---------------------------------------------------------------------
+
+ AC_C_INLINE
+ AC_HEADER_TIME
+ AC_CHECK_HEADERS([sys/time.h c_asm.h intrinsics.h mach/mach_time.h])
+
+ AC_CHECK_TYPE([hrtime_t],[AC_DEFINE(HAVE_HRTIME_T, 1, [Define to 1 if hrtime_t is defined in <sys/time.h>])],,[#if HAVE_SYS_TIME_H
+#include <sys/time.h>
+#endif])
+
+ AC_CHECK_FUNCS([gethrtime read_real_time time_base_to_time clock_gettime mach_absolute_time])
+
+ dnl Cray UNICOS _rtc() (real-time clock) intrinsic
+ AC_MSG_CHECKING([for _rtc intrinsic])
+ rtc_ok=yes
+ AC_TRY_LINK([#ifdef HAVE_INTRINSICS_H
+#include <intrinsics.h>
+#endif], [_rtc()], [AC_DEFINE(HAVE__RTC,1,[Define if you have the UNICOS _rtc() intrinsic.])], [rtc_ok=no])
+ AC_MSG_RESULT($rtc_ok)
+
+ dnl ---------------------------------------------------------------------
+*/
+
+/***************************************************************************/
+
+#if TIME_WITH_SYS_TIME
+# include <sys/time.h>
+# include <time.h>
+#else
+# if HAVE_SYS_TIME_H
+# include <sys/time.h>
+# else
+# include <time.h>
+# endif
+#endif
+
+#define INLINE_ELAPSED(INL) static INL double elapsed(ticks t1, ticks t0) \
+{ \
+ return (double)(t1 - t0); \
+}
+
+/*----------------------------------------------------------------*/
+/* Solaris */
+#if (__sparc)
+// #if defined(HAVE_GETHRTIME) && defined(HAVE_HRTIME_T) && !defined(HAVE_TICK_COUNTER)
+typedef hrtime_t ticks;
+
+#define getticks gethrtime
+
+INLINE_ELAPSED(inline)
+
+#define HAVE_TICK_COUNTER
+#endif
+
+/*----------------------------------------------------------------*/
+/* AIX v. 4+ routines to read the real-time clock or time-base register */
+#if defined(HAVE_READ_REAL_TIME) && defined(HAVE_TIME_BASE_TO_TIME) && !defined(HAVE_TICK_COUNTER)
+typedef timebasestruct_t ticks;
+
+static inline ticks getticks(void)
+{
+ ticks t;
+ read_real_time(&t, TIMEBASE_SZ);
+ return t;
+}
+
+static inline double elapsed(ticks t1, ticks t0) /* time in nanoseconds */
+{
+ time_base_to_time(&t1, TIMEBASE_SZ);
+ time_base_to_time(&t0, TIMEBASE_SZ);
+ return ((t1.tb_high - t0.tb_high) * 1e9 + (t1.tb_low - t0.tb_low));
+}
+
+#define HAVE_TICK_COUNTER
+#endif
+
+/*----------------------------------------------------------------*/
+/*
+ * PowerPC ``cycle'' counter using the time base register.
+ */
+#if ((defined(__GNUC__) && (defined(__powerpc__) || defined(__ppc__))) || (defined(__MWERKS__) && defined(macintosh))) && !defined(HAVE_TICK_COUNTER)
+typedef unsigned long long ticks;
+
+static __inline__ ticks getticks(void)
+{
+ unsigned int tbl, tbu0, tbu1;
+
+ do {
+ __asm__ __volatile__ ("mftbu %0" : "=r"(tbu0));
+ __asm__ __volatile__ ("mftb %0" : "=r"(tbl));
+ __asm__ __volatile__ ("mftbu %0" : "=r"(tbu1));
+ } while (tbu0 != tbu1);
+
+ return (((unsigned long long)tbu0) << 32) | tbl;
+}
+
+INLINE_ELAPSED(__inline__)
+
+#define HAVE_TICK_COUNTER
+#endif
+
+/* MacOS/Mach (Darwin) time-base register interface (unlike UpTime,
+ from Carbon, requires no additional libraries to be linked). */
+#if defined(HAVE_MACH_ABSOLUTE_TIME) && defined(HAVE_MACH_MACH_TIME_H) && !defined(HAVE_TICK_COUNTER)
+#include <mach/mach_time.h>
+typedef uint64_t ticks;
+#define getticks mach_absolute_time
+INLINE_ELAPSED(__inline__)
+#define HAVE_TICK_COUNTER
+#endif
+
+/*----------------------------------------------------------------*/
+/*
+ * Pentium cycle counter
+ */
+#if (defined(__GNUC__) || defined(__ICC)) && defined(__i386__) && !defined(HAVE_TICK_COUNTER)
+typedef unsigned long long ticks;
+
+static __inline__ ticks getticks(void)
+{
+ ticks ret;
+
+ __asm__ __volatile__("rdtsc": "=A" (ret));
+ /* no input, nothing else clobbered */
+ return ret;
+}
+
+INLINE_ELAPSED(__inline__)
+
+#define HAVE_TICK_COUNTER
+#define TIME_MIN 5000.0 /* unreliable pentium IV cycle counter */
+#endif
+
+/* Visual C++ -- thanks to Morten Nissov for his help with this */
+#if _MSC_VER >= 1200 && _M_IX86 >= 500 && !defined(HAVE_TICK_COUNTER)
+#include <windows.h>
+typedef LARGE_INTEGER ticks;
+#define RDTSC __asm __emit 0fh __asm __emit 031h /* hack for VC++ 5.0 */
+
+static __inline ticks getticks(void)
+{
+ ticks ret;
+
+ __asm {
+ RDTSC
+ mov ret.HighPart, edx
+ mov ret.LowPart, eax
+ }
+ return ret;
+}
+
+static __inline double elapsed(ticks t1, ticks t0)
+{
+ return (double)(t1.QuadPart - t0.QuadPart);
+}
+
+#define HAVE_TICK_COUNTER
+#define TIME_MIN 5000.0 /* unreliable pentium IV cycle counter */
+#endif
+
+/*----------------------------------------------------------------*/
+/*
+ * X86-64 cycle counter
+ */
+#if defined(__GNUC__) && defined(__x86_64__) && !defined(HAVE_TICK_COUNTER)
+typedef unsigned long long ticks;
+
+static __inline__ ticks getticks(void)
+{
+ unsigned a, d;
+ asm volatile("rdtsc" : "=a" (a), "=d" (d));
+ return ((ticks)a) | (((ticks)d) << 32);
+}
+
+INLINE_ELAPSED(__inline__)
+
+#define HAVE_TICK_COUNTER
+#endif
+
+/* Visual C++ (FIXME: how to detect compilation for x86-64?) */
+#if _MSC_VER >= 1400 && !defined(HAVE_TICK_COUNTER)
+typedef ULONG64 ticks;
+
+#define getticks __rdtsc
+
+INLINE_ELAPSED(__inline)
+
+#define HAVE_TICK_COUNTER
+#endif
+
+/*----------------------------------------------------------------*/
+/*
+ * IA64 cycle counter
+ */
+#if defined(__GNUC__) && defined(__ia64__) && !defined(HAVE_TICK_COUNTER)
+typedef unsigned long ticks;
+
+static __inline__ ticks getticks(void)
+{
+ ticks ret;
+
+ __asm__ __volatile__ ("mov %0=ar.itc" : "=r"(ret));
+ return ret;
+}
+
+INLINE_ELAPSED(__inline__)
+
+#define HAVE_TICK_COUNTER
+#endif
+
+/* HP/UX IA64 compiler, courtesy Teresa L. Johnson: */
+#if defined(__hpux) && defined(__ia64) && !defined(HAVE_TICK_COUNTER)
+#include <machine/sys/inline.h>
+typedef unsigned long ticks;
+
+static inline ticks getticks(void)
+{
+ ticks ret;
+
+ ret = _Asm_mov_from_ar (_AREG_ITC);
+ return ret;
+}
+
+INLINE_ELAPSED(inline)
+
+#define HAVE_TICK_COUNTER
+#endif
+
+/* intel's ecc compiler */
+#if defined(__ECC) && defined(__ia64__) && !defined(HAVE_TICK_COUNTER)
+typedef unsigned long ticks;
+#include <ia64intrin.h>
+
+static __inline__ ticks getticks(void)
+{
+ return __getReg(_IA64_REG_AR_ITC);
+}
+
+INLINE_ELAPSED(__inline__)
+
+#define HAVE_TICK_COUNTER
+#endif
+
+/*----------------------------------------------------------------*/
+/*
+ * PA-RISC cycle counter
+ */
+#if defined(__hppa__) || defined(__hppa) && !defined(HAVE_TICK_COUNTER)
+typedef unsigned long ticks;
+
+# ifdef __GNUC__
+static __inline__ ticks getticks(void)
+{
+ ticks ret;
+
+ __asm__ __volatile__("mfctl 16, %0": "=r" (ret));
+ /* no input, nothing else clobbered */
+ return ret;
+}
+# else
+# include <machine/inline.h>
+static inline unsigned long getticks(void)
+{
+ register ticks ret;
+ _MFCTL(16, ret);
+ return ret;
+}
+# endif
+
+INLINE_ELAPSED(inline)
+
+#define HAVE_TICK_COUNTER
+#endif
+
+/*----------------------------------------------------------------*/
+/* S390, courtesy of James Treacy */
+#if defined(__GNUC__) && defined(__s390__) && !defined(HAVE_TICK_COUNTER)
+typedef unsigned long long ticks;
+
+static __inline__ ticks getticks(void)
+{
+ ticks cycles;
+ __asm__("stck 0(%0)" : : "a" (&(cycles)) : "memory", "cc");
+ return cycles;
+}
+
+INLINE_ELAPSED(__inline__)
+
+#define HAVE_TICK_COUNTER
+#endif
+/*----------------------------------------------------------------*/
+#if defined(__GNUC__) && defined(__alpha__) && !defined(HAVE_TICK_COUNTER)
+/*
+ * The 32-bit cycle counter on alpha overflows pretty quickly,
+ * unfortunately. A 1GHz machine overflows in 4 seconds.
+ */
+typedef unsigned int ticks;
+
+static __inline__ ticks getticks(void)
+{
+ unsigned long cc;
+ __asm__ __volatile__ ("rpcc %0" : "=r"(cc));
+ return (cc & 0xFFFFFFFF);
+}
+
+INLINE_ELAPSED(__inline__)
+
+#define HAVE_TICK_COUNTER
+#endif
+
+/*----------------------------------------------------------------*/
+#if defined(__GNUC__) && defined(__sparc_v9__) && !defined(HAVE_TICK_COUNTER)
+typedef unsigned long ticks;
+
+static __inline__ ticks getticks(void)
+{
+ ticks ret;
+ __asm__ __volatile__("rd %%tick, %0" : "=r" (ret));
+ return ret;
+}
+
+INLINE_ELAPSED(__inline__)
+
+#define HAVE_TICK_COUNTER
+#endif
+
+/*----------------------------------------------------------------*/
+#if defined(__DECC) && defined(__alpha) && defined(HAVE_C_ASM_H) && !defined(HAVE_TICK_COUNTER)
+# include <c_asm.h>
+typedef unsigned int ticks;
+
+static __inline ticks getticks(void)
+{
+ unsigned long cc;
+ cc = asm("rpcc %v0");
+ return (cc & 0xFFFFFFFF);
+}
+
+INLINE_ELAPSED(__inline)
+
+#define HAVE_TICK_COUNTER
+#endif
+/*----------------------------------------------------------------*/
+/* SGI/Irix */
+#if defined(HAVE_CLOCK_GETTIME) && defined(CLOCK_SGI_CYCLE) && !defined(HAVE_TICK_COUNTER)
+typedef struct timespec ticks;
+
+static inline ticks getticks(void)
+{
+ struct timespec t;
+ clock_gettime(CLOCK_SGI_CYCLE, &t);
+ return t;
+}
+
+static inline double elapsed(ticks t1, ticks t0)
+{
+ return (double)(t1.tv_sec - t0.tv_sec) * 1.0E9 +
+ (double)(t1.tv_nsec - t0.tv_nsec);
+}
+#define HAVE_TICK_COUNTER
+#endif
+
+/*----------------------------------------------------------------*/
+/* Cray UNICOS _rtc() intrinsic function */
+#if defined(HAVE__RTC) && !defined(HAVE_TICK_COUNTER)
+#ifdef HAVE_INTRINSICS_H
+# include <intrinsics.h>
+#endif
+
+typedef long long ticks;
+
+#define getticks _rtc
+
+INLINE_ELAPSED(inline)
+
+#define HAVE_TICK_COUNTER
+#endif
+
diff -Naur ocaml-4.02.1/metalib/.depend ocaml-ber-n102/metalib/.depend
--- ocaml-4.02.1/metalib/.depend 1970-01-01 01:00:00.000000000 +0100
+++ ocaml-ber-n102/metalib/.depend 2015-01-10 16:27:06.936030975 +0000
@@ -0,0 +1,19 @@
+metatop.cmi :
+print_code.cmi : runcode.cmi
+reify_type.cmi :
+runcode.cmi :
+trxtime.cmi :
+berstart.cmo :
+berstart.cmx :
+bertop.cmo :
+bertop.cmx :
+print_code.cmo : runcode.cmi print_code.cmi
+print_code.cmx : runcode.cmx print_code.cmi
+reify_type.cmo : reify_type.cmi
+reify_type.cmx : reify_type.cmi
+run_native.cmo :
+run_native.cmx :
+runcode.cmo : runcode.cmi
+runcode.cmx : runcode.cmi
+trxtime.cmo : trxtime.cmi
+trxtime.cmx : trxtime.cmi
diff -Naur ocaml-4.02.1/metalib/Files.txt ocaml-ber-n102/metalib/Files.txt
--- ocaml-4.02.1/metalib/Files.txt 1970-01-01 01:00:00.000000000 +0100
+++ ocaml-ber-n102/metalib/Files.txt 2015-01-10 16:27:06.936030975 +0000
@@ -0,0 +1,68 @@
+OCaml files affected by the BER MetaOCaml.
+Search for NNN in each files for concrete changes
+
+./Makefile
+
+done ./parsing/lexer.mll
+done ./parsing/parser.mly
+done ./parsing/pprintast.ml new in 4.01
+
+done ./typing/predef.ml
+done ./typing/predef.mli
+
+
+done ./typing/typecore.ml
+
+ ./typing/trx.mli
+ ./typing/trx.ml
+
+
+No longer changed in N102
+
+./ocamldoc/Makefile
+
+./parsing/parsetree.mli
+./parsing/printast.ml trivial
+./parsing/ast_mapper.ml new in 4.01, trivial
+
+./typing/typedtree.mli
+./typing/typedtree.ml
+
+./typing/printtyped.ml did not exist before, trivial changes
+./typing/typedtreeIter.ml in 4.01, moved from tools, trivial changes
+./typing/typedtreeMap.ml new in 4.01, trivial changes
+
+./typing/env.mli
+./typing/env.ml
+./typing/envaux.ml new in 4.01, trivial changes
+
+./typing/typecore.mli
+./typing/typemod.ml
+
+./tools/depend.ml
+
+./tools/ocamlprof.ml
+./tools/untypeast.ml did not exist before, trivial changes
+./tools/tast_iter.ml new in 4.01
+
+
+No longer changed in N101
+ ./typing/ident.ml No longer changed
+ ./tools/addlabels.ml not built any more?
+ ./typing/ident.mli No longer changed
+ ./typing/typeclass.ml No longer changed
+ ./typing/cmt_format.ml in 4.01, no longer changed
+
+ ./typing/unused_var.ml No longer present in Ocaml 4
+
+
+done ./asmcomp/cmmgen.ml Const_csp_value will cause fatal error
+ Const_csp_value must not appear in native code
+
+./bytecomp/lambda.ml Only adding Const_csp_value
+./bytecomp/lambda.mli
+./bytecomp/printlambda.ml
+./bytecomp/translcore.ml
+./bytecomp/symtable.ml
+
+./tools/dumpobj.ml (only printing Const_csp_value)
diff -Naur ocaml-4.02.1/metalib/Generalization-levels.txt ocaml-ber-n102/metalib/Generalization-levels.txt
--- ocaml-4.02.1/metalib/Generalization-levels.txt 1970-01-01 01:00:00.000000000 +0100
+++ ocaml-ber-n102/metalib/Generalization-levels.txt 2015-01-10 16:27:06.936030975 +0000
@@ -0,0 +1,309 @@
+Type checking: generalization and regions
+
+OCaml implements type generalization in an efficient and interesting
+way, which also ensures that types defined within (nested) modules do
+not escape their scope. The technique hence enforces the region
+discipline for locally introduced type constructors. It is intriguing
+how generalization and regions are handled so uniformly. Truly they
+are deeply related.
+
+Unfortunately, this technique does not seem to be documented at all,
+aside from a couple of brief puzzling comments in the OCaml source
+code (directory typing/ in the OCaml distribution). The present
+document is probably its only explanation.
+
+To be certain, the type generalization in OCaml achieves the same
+result as the textbook algorithm: a free variable in the type of the
+expression 'e' that occurs in 'let x = e in body' is generalized if
+the variable does not occur in the type environment and 'e' is
+syntactically a value (more precisely, nonexpansive -- that is, has no
+visible effect). OCaml achieves this goal in an unexpected way.
+
+Every type expression in OCaml -- type variable, type constant, a
+constructor expression etc. has a so-called _level_. (See type_expr in
+typing/types.mli.) The level is a positive integer, starting with 1
+(see typing/ctype.ml). A very large positive integer -- which should
+be treated as the inaccessible ordinal omega -- is dedicated to a
+generic_level. [Aside: A rare code comment, in ctype.ml, claims that
+levels decrease from generic_level. It is a but misleading. Also, type
+levels, which are mutable, are overloaded for type tree traversal. I
+don't know how much efficiency it buys but it makes the code confusing
+and fragile: one cannot nest traversal functions.] A mutable global
+current_level (in ctype.ml) tracks the current level. A new type
+expression (created by newty () or newvar ()) receives the
+current_level. The current_level is increased by enter_def() and
+decreased by end_def(), which should be properly nested.
+
+When two types are unified, their levels are updated to be the
+smallest of the two. Alas, this crucial property is documented nowhere
+and has to be deduced from the code for the unification algorithm,
+which takes 1634 lines of code, in ctype.ml. Yes, it is that long.
+
+Let's take an example. The (very simplified) code for type-checking
+'let x = e in body' is as follows
+
+ let e_typed =
+ enter_def ();
+ let r = type_check env e_source in
+ end_def ();
+ r
+ in
+ generalize e_typed.exp_type;
+ let new_env = bind env x e_typed.exp_type in
+ type_check new_env body_source
+
+Here, e_source is the AST (Parsetree) for the expression 'e' and
+e_typed is the Typedtree version of the expression (with the attached
+inferred type, in the field exp_type).
+
+Suppose at the beginning of the code, curr_level was 1 and e_source
+was the AST for the identity function "fun x -> x". The statement
+enter_def() increases the level by 1. When handling "fun x -> x" the
+type checker creates a new type-variable, call it ty_a, for the type
+of the argument. That variable receives the current level, which is
+now 2. The type-checked expression e_typed will have the type of
+Tarrow (ty_a,ty_a). Next comes generalize, defined in ctype.ml. It
+traverses the argument type expression and checks the level of every
+component. If that level is greater than the current_level and is not
+already generic_level, it is set to generic_level. In the code above,
+generalize is executed after end_def(), when the current_level is back
+to 1. When generalize traverses e_typed and comes across ty_a (whose
+level is 2), it sets the level of ty_a to generic_level. Hence ty_a
+becomes implicitly universally quantified. Type variables of
+generic_level are printed like "'a"; the type variables of other
+levels are printed as "'_a".
+
+To see that the algorithm is sound, consider the type checking of
+
+ fun x -> let f = fun z -> x in ...
+
+When handling "fun z -> x", the type-checker will create a type
+variable for the argument, call it ty_z, and the type argument for the
+result, call it ty_r. Both will have the level 2 (assuming initially
+the current_level was 1). The variable ty_r is then unified with the
+type of x, which is ty_x. Technically, ty_x is modified to be Tlink
+(ty_r). Importantly, the level of ty_r is set to the smallest of ty_r
+and ty_x, which is 1, the level of ty_x. The type of f is hence
+Tarrow(ty_z,ty_r). When generalize traverses this type, it will
+generalize ty_z (since its level was 2, greater than the current 1),
+but not ty_r, since its level is 1. The difference is seen here:
+
+ # fun x -> let f = fun z -> x in (f true, f false, f true = 1);;
+ - : int -> int * int * bool = <fun>
+
+ # fun x -> let f = fun z -> x in (f true, f false, f true = 1, f false = false)
+ ^^^^^
+ Error: This expression has type bool but an expression was expected of type
+ int
+
+In summary: if we want to type check an expression and generalize its
+type, we should do
+
+ let ty =
+ enter_def ();
+ let r = ... let tv = newvar() in ... (... tv ...)
+ end_def ();
+ r
+ generalize ty
+
+If tv wasn't unified with something that existed in the environment
+before enter_def(), the variable will be generalized. Levels thus is
+a neat technique to avoid traversing the whole environment checking
+for free occurrence of a particular type variable.
+
+Interestingly, levels have another use, enforcing the region
+discipline for local type declarations. Before we get to it, let's
+take a moment to appreciate the true complexity of generalization.
+The let-generalization in OCaml is far more complex than I have
+outlined. First, the let-statement has the general form
+
+ let [rec] pattern = exp and pattern = exp ... in body
+
+The type checker receives the list of pattern-expression pairs,
+and the recursion-flag. The complete code takes 160 lines. Here is the
+end of it
+
+ begin_def ();
+ ...
+ let exp_list =
+ List.map2
+ (fun (spat, sexp) (pat, slot) -> .... (* type checking of expressions *)
+ type_expect exp_env sexp pat.pat_type)
+ spat_sexp_list pat_slot_list in
+ ...
+ end_def();
+ List.iter2
+ (fun pat exp ->
+ if not (is_nonexpansive exp) then
+ iter_pattern (fun pat -> generalize_expansive env pat.pat_type) pat)
+ pat_list exp_list;
+ List.iter
+ (fun pat -> iter_pattern (fun pat -> generalize pat.pat_type) pat)
+ pat_list;
+ (List.combine pat_list exp_list, new_env, unpacks)
+
+
+We see the general template:
+ begin_def(); ... newvar () ... end_def(); generalize.
+But there is another traversal of the type, with
+generalize_expansive. That function is invoked only if the expression
+is expansive, that is, may have a visible effect -- for example, it is
+an application. The procedure generalize_expansive (in ctype.ml)
+traverses its argument type_expression; when it comes across a
+constructed type Tconstr(p,args) (such as list type, etc), its checks
+for the variance of the arguments. If an arg is covariant (to be
+precise, `weakly covariant'), arg's levels that are greater than the
+current level are set to generic_level. Otherwise, arg's levels that
+are greater than the current_level are set to the current_level. The
+subsequent generalize will leave those levels as they
+are. Incidentally, the argument of the type 'a ref is not weakly
+covariant. This is how a so-called relaxed value restriction is
+implemented, which is responsible for
+
+ # let x = (fun y -> print_string "ok"; y) [];;
+ ok
+ val x : 'a list = []
+
+Here, x is bound to an application, which is not a value, which has
+effects, and which is expansive. And yet the type of x is generalized.
+SML would not. (BTW, all examples are checked with the MetaOCaml 4.00,
+which is a superset of OCaml 4.00). Without the relaxed value
+restriction, MetaOCaml will be hardly usable. For example,
+ let x = .<1 + .~(...)>.
+is an expression, so the classifier cannot be generalized and hence
+x cannot be run.
+
+Finally we come to regions. ML has modules, which may define (local)
+types. The locally introduced types can be used within the scope of
+the module and in children modules. But the local type should not escape
+the scope of the module. OCaml type-checker thus implements Regions
+for type constructors.
+
+Here is the example of an escaping type constructor (taken from a rare
+comment in OCaml type checker, ctype.ml)
+
+ let x = ref []
+ module M = struct type t let _ = (x : t list ref) end
+
+The module M defines a local type t. The variable x has the
+non-generic type '_a list ref. The type attribution causes x to have
+the type (x : t list ref), so the local type constructor t escapes.
+
+To see how levels help, consider type checking of local modules
+
+ let module M = struct type t let foo = ... end in
+ M.foo
+
+If 'foo' has the type that mentions M.t, then M.t would've escaped.
+Here is the code for the type-checking of local modules (excerpted
+from typecore.ml).
+
+ | Pexp_letmodule(name, smodl, sbody) ->
+ let ty = newvar() in
+ (* remember original level *)
+ begin_def ();
+ Ident.set_current_time ty.level;
+ let context = Typetexp.narrow () in
+ let modl = !type_module env smodl in
+ let (id, new_env) = Env.enter_module name.txt modl.mod_type env in
+ Ctype.init_def(Ident.current_time());
+ Typetexp.widen context;
+ let body = type_expect new_env sbody ty_expected in
+ (* go back to original level *)
+ end_def ();
+ (* Unification of body.exp_type with the fresh variable ty
+ fails if and only if the prefix condition is violated,
+ i.e. if generative types rooted at id show up in the
+ type body.exp_type. Thus, this unification enforces the
+ scoping condition on "let module". *)
+ begin try
+ Ctype.unify_var new_env ty body.exp_type
+ with Unify _ ->
+ raise(Error(loc, Scoping_let_module(name.txt, body.exp_type)))
+ end;
+ re {
+ exp_desc = Texp_letmodule(id, name, modl, body);
+ exp_loc = loc; exp_extra = [];
+ exp_type = ty;
+ exp_env = env }
+
+To understand what is going on, we should examine
+ unify_var env tvar t2
+which unifies the type variable tvar with the type t2. As usual,
+unify_var does the occurs check, and then makes tvar to be Tlink
+(t2). It also sets the level of t2 to be the min(t2.level,
+tvar.level). The function does something else: if t2.level >
+tvar.level, more checks are done. When the above condition is true,
+the type expression t2 was added at a higher level (or, at an inner
+level) compared to tvar. There is a danger than unification will leak
+the local type variables.
+
+The extra check, in Ctype.update_level, checks if t2 is a
+TConstr, object, variant, record or package. If t2 is Tconstr(p,_,_)
+where p is the `identifier' of a type constructor, we check if
+the binding time of p is less or equal than tvar.level. If not, an
+error is reported. We should explain binding time: when an identifier
+is seen in a binding position and entered into the environment, the
+identifier is timestamped with the current `time', which is an
+increasing integer. Remember the line
+ Ident.set_current_time ty.level;
+in the above code? It sets the time stamp counter to the level of an
+external type variable ty plus one (see begin_def()). If the local
+module defines a type constructor, its binding time will be greater
+than the level of ty. If that type constructor is mentioned in the
+type of the body, Ctype.unify_var will encounter it while lowering the
+levels to ty.level, and reports the error. Thus the type checker
+enforces the invariant that the binding type of every type constructor
+is strictly less than its level of a type it forms. The invariant
+ensures the region discipline.
+
+
+
+Appendix. How to create fresh type variables
+
+There are two functions to create fresh type variables:
+
+ newvar : ?name:string -> unit -> type_exp
+ newgenvar : ?name:string -> unit -> type_exp
+
+Both take the optional argument ?name to give the name to the
+variable. The name will be chosen automatically otherwise.
+
+The function newvar() creates a variable at the current_level whereas
+newgenvar() creates at the generic_level. In the code
+
+ let ty1 = newvar () in
+ unify env ty1 some_type
+
+ let ty2 = newgenvar () in
+ unify env ty2 some_type
+
+both ty1 and ty2 behave similarly: the level of ty1 will be lowered to
+that of some_type (if some_type has level less than the current). The
+level of ty2 will most definitely will be lowered (unless some_type is
+also at generic_level) since generic_level is the highest.
+
+The difference emerges in
+
+ let ty1 = newvar () in
+ let list_type = newgenty (Tconstr(p_list, [ty1])) in
+ let texp = instance env list_type in
+ unify env texp some_type
+
+ let ty2 = newgenvar () in
+ let list_type = newgenty (Tconstr(p_list, [ty2])) in
+ let texp = instance env list_type in
+ unify env texp some_type
+
+The function instance copies the type (creates a Tsubst node, to be
+precise), if it is generic. That is, in
+ let ty = newvar () in instance env ty
+instance is the identity function. Nowever, in
+ let ty = newgenvar () in instance env ty
+instance copies the variable. Therefore, in the first snippet above,
+the final unification may affect list_type (instantiating ty1). It
+will not in the second snippet since unify will act on the copy of
+ty2.
+
+
+
diff -Naur ocaml-4.02.1/metalib/gprint/gprint.ml ocaml-ber-n102/metalib/gprint/gprint.ml
--- ocaml-4.02.1/metalib/gprint/gprint.ml 1970-01-01 01:00:00.000000000 +0100
+++ ocaml-ber-n102/metalib/gprint/gprint.ml 2015-01-10 16:27:06.936030975 +0000
@@ -0,0 +1,139 @@
+(** Generic print
+
+
+If this ever gets integrated with MetaOCaml, the simplest implementation
+will be to change the AST printing: when is about to print CSP,
+check the type...
+
+$Id: gprint.ml,v 1.3 2006/04/17 01:46:50 oleg Exp $
+*)
+
+
+open Ident (* Just to make sure Ident is loaded first! *)
+
+
+(* Given an expression like .<something>., extract the parse tree
+ corresponding to something.
+ Recall that an object of type code is actually a parsetree
+*)
+
+let get_elem_parsetree (x : ('a,'b) code) : Parsetree.expression =
+ Obj.magic x
+;;
+
+(* Just a helper, for debugging purposes *)
+let type_to_str (x : Typedtree.expression) =
+ Printtyp.type_expr Format.str_formatter (x.Typedtree.exp_type);
+ Format.flush_str_formatter ();;
+
+(* First, we do a consistency check: Env.initial is the same as
+ the initial environment that corresponds to the host system
+*)
+
+(*
+let initial_env_ids =
+ Predef.build_initial_env
+ (fun iden _ lst -> Ident.name iden :: lst)
+ (fun iden _ lst -> Ident.name iden :: lst)
+ []
+*)
+
+
+(* Detailed printing function (unlike Path.name), showing timestamps, etc.*)
+let string_of_ident i =
+ Ident.print Format.str_formatter i;
+ Format.flush_str_formatter ()
+
+
+let rec string_of_path p =
+ let fmt = Format.str_formatter in
+ let rec loop = function
+ | Path.Pident i -> Ident.print fmt i
+ | Path.Pdot (p,s,fl) ->
+ loop p; Format.fprintf fmt ".%s(%d)" s fl
+ | Path.Papply _ -> Format.fprintf fmt "Papply"
+ in loop p;
+ Format.flush_str_formatter ()
+;;
+
+(* Get the env associated with the host compiler: true env *)
+(* This is somewhat silly; still, it's better to be safe than sorry.
+ The inconsistency did cause me a lot of trouble once.
+*)
+let true_env =
+ match get_elem_parsetree .<[None]>. with
+ {Parsetree.pexp_ext = Some tr} ->
+ let t : Typedtree.expression = Obj.obj tr in
+ t.Typedtree.exp_env
+ | _ -> assert false
+;;
+
+
+let () =
+ let itrue = (* what the type "int" is in the true env *)
+ string_of_path
+ (fst (Env.lookup_type (Longident.Lident "int") true_env)) in
+ let iint = (* what it is in the Env.initial *)
+ string_of_path
+ (fst (Env.lookup_type (Longident.Lident "int") Env.initial)) in
+ if itrue = iint then ()
+ else failwith ("Inconsistent Env: " ^ itrue ^ " vs. " ^ iint ^
+ "Ensure that the module Ident is loaded first!")
+;;
+
+
+(** The printing itself *)
+
+(* EvalPath is used only to print exceptions. For now, we force
+ Genprintval to make a ``feeble attempt''
+*)
+module EvalPath = struct
+ type value = Obj.t
+ exception Error
+ let eval_path p = raise Error
+ let same_value v1 v2 = (v1 == v2)
+end
+
+module Printer = Genprintval.Make(Obj)(EvalPath)
+;;
+
+let max_printer_depth = ref 100
+let max_printer_steps = ref 300
+
+(* Before attempting to print the value, check to make sure
+ that Config.load_path is set. Otherwise,
+ the printer could not find .cmi files with the
+ needed type declarations.
+*)
+
+let print_value env obj ty =
+ if !Config.load_path = [] then Compile.init_path();
+ Printer.outval_of_value !max_printer_steps !max_printer_depth
+ (fun _ _ _ -> None) env obj ty
+;;
+
+
+(* Analyze the parse tree. If it describes a CSP value, extract the type
+ and use print_value. Otherwise, use printAST
+*)
+
+let print_parsetree fmt = function
+ {Parsetree.pexp_desc =
+ Parsetree.Pexp_cspval (v, _);
+ Parsetree.pexp_ext = Some tr} ->
+ let t : Typedtree.expression = Obj.obj tr in
+ let () = !Oprint.out_value fmt
+ (print_value t.Typedtree.exp_env v t.Typedtree.exp_type) in
+ type_to_str t
+ | pt -> Print_code.inpc fmt pt; "<manifest>"
+;;
+
+
+let fprint fmt (x : ('a,'b) code) =
+ print_parsetree fmt (get_elem_parsetree x)
+;;
+
+let print (x : ('a,'b) code) =
+ fprint Format.std_formatter x
+;;
+
diff -Naur ocaml-4.02.1/metalib/gprint/gprint.mli ocaml-ber-n102/metalib/gprint/gprint.mli
--- ocaml-4.02.1/metalib/gprint/gprint.mli 1970-01-01 01:00:00.000000000 +0100
+++ ocaml-ber-n102/metalib/gprint/gprint.mli 2015-01-10 16:27:06.936030975 +0000
@@ -0,0 +1,14 @@
+(** Generic print
+
+ The interface is similar to that in toplevel/printval.mli
+
+$Id: gprint.mli,v 1.1 2006/04/15 11:27:37 oleg Exp $
+*)
+
+
+(* The output is the type of the printed expression, as a string *)
+val fprint : Format.formatter -> ('a,'b) code -> string
+val print : ('a,'b) code -> string
+
+val max_printer_depth: int ref
+val max_printer_steps: int ref
diff -Naur ocaml-4.02.1/metalib/gprint/gprint_toplevel.ml ocaml-ber-n102/metalib/gprint/gprint_toplevel.ml
--- ocaml-4.02.1/metalib/gprint/gprint_toplevel.ml 1970-01-01 01:00:00.000000000 +0100
+++ ocaml-ber-n102/metalib/gprint/gprint_toplevel.ml 2015-01-10 16:27:06.936030975 +0000
@@ -0,0 +1,54 @@
+(** Generic print
+
+This file is for using the generic print facility with metaocaml:
+unmodified MetaOCaml toplevel.
+
+First, correct the paths below (to point to the MetaOCaml installation)
+and then #use the file.
+
+The file loads a few modules needed by the generic print facility.
+
+THE ORDER OF LOADING IS IMPORTANT!!!
+
+In particular, "ident.cmo" must be loaded first. It is a stateful module,
+whose state is the typestamp for identifiers. The module Predef uses
+Ident.create when building identifiers for pre-defined types such as
+int. It is imperative that predefined identifiers accessible via
+Predef here have the same timestamp as those that existed in the host
+code: so Meta-level and the host-level use the same predefined type
+identifiers.
+
+ $Id: gprint_toplevel.ml,v 1.2 2006/04/15 11:27:37 oleg Exp $
+*)
+
+#directory "/home/oleg/Cache/ometa-cvs/parsing";;
+#directory "/home/oleg/Cache/ometa-cvs/typing";;
+#directory "/home/oleg/Cache/ometa-cvs/toplevel";;
+#directory "/home/oleg/Cache/ometa-cvs/utils";;
+
+
+(* This must be loaded first! It is stateful, and affects Predef *)
+#load "ident.cmo";;
+
+#load "misc.cmo";;
+#load "path.cmo";;
+#load "types.cmo";;
+#load "btype.cmo";;
+#load "tbl.cmo";;
+#load "subst.cmo";;
+#load "predef.cmo";;
+#load "datarepr.cmo";;
+#load "config.cmo";;
+#load "consistbl.cmo";;
+#load "env.cmo";;
+#load "clflags.cmo";;
+#load "ctype.cmo";;
+#load "printast.cmo";;
+#load "oprint.cmo";;
+#load "primitive.cmo";;
+#load "printtyp.cmo";;
+#load "genprintval.cmo";;
+
+
+(* Finally, load ou gprint proper *)
+#use "gprint.ml";;
diff -Naur ocaml-4.02.1/metalib/gprint/Makefile ocaml-ber-n102/metalib/gprint/Makefile
--- ocaml-4.02.1/metalib/gprint/Makefile 1970-01-01 01:00:00.000000000 +0100
+++ ocaml-ber-n102/metalib/gprint/Makefile 2015-01-10 16:27:06.936030975 +0000
@@ -0,0 +1,151 @@
+# Building and testing the Generic Print facility
+#
+# make all
+# to build the library
+# make test_toponly
+# test with the top-level. No need to compile anything
+# make testb
+# test gprint in byte-code programs
+# make testo
+# test gprint in natively-compiled programs
+#
+#
+# $Id: Makefile,v 1.2 2006/04/17 01:46:50 oleg Exp $
+
+# Location of the OCaml distribution directory
+CAMLROOT=../..
+
+include $(CAMLROOT)/config/Makefile
+
+RUNTIME=$(CAMLROOT)/boot/ocamlrun
+INCLUDES=-I $(CAMLROOT)/utils \
+ -I $(CAMLROOT)/parsing -I $(CAMLROOT)/typing -I $(CAMLROOT)/bytecomp \
+ -I $(CAMLROOT)/asmcomp -I $(CAMLROOT)/driver \
+ -I $(CAMLROOT)/toplevel -I $(CAMLROOT)/boot \
+ -I $(CAMLROOT)/metalib
+COMPILER=$(CAMLROOT)/ocamlc
+CAMLC=$(RUNTIME) $(COMPILER) $(INCLUDES)
+COMPFLAGS=-g -warn-error A -nostdlib
+OPTCOMPILER=$(CAMLROOT)/ocamlopt
+CAMLOPT=$(RUNTIME) $(OPTCOMPILER)
+OPTCOMPFLAGS=-warn-error A -nostdlib
+CAMLDEP=$(CAMLROOT)/boot/ocamlrun $(CAMLROOT)/tools/ocamldep
+MOCAMLTOP=$(BINDIR)/metaocaml
+MOCAMLC=$(BINDIR)/metaocamlc
+
+
+.SUFFIXES: .mli .ml .cmi .cmo .cmx
+
+.mli.cmi:
+ $(CAMLC) $(COMPFLAGS) -c $<
+
+.ml.cmi:
+ $(CAMLC) $(COMPFLAGS) -c $<
+
+.ml.cmo:
+ $(CAMLC) $(COMPFLAGS) -c $<
+
+.ml.cmx:
+ $(CAMLOPT) $(OPTCOMPFLAGS) -c $<
+
+
+all: gprint.cma
+
+install:
+ cp gprint.cmi gprint.cma \
+ $(LIBDIR)
+
+
+# MetaOCaml modules to build the library.
+# The order is mighty important! In particular, ident.cmo must be first!
+LIBLIBMOD= ident.cmo misc.cmo path.cmo types.cmo btype.cmo tbl.cmo \
+ subst.cmo predef.cmo datarepr.cmo config.cmo consistbl.cmo \
+ env.cmo clflags.cmo ctype.cmo printast.cmo oprint.cmo \
+ primitive.cmo printtyp.cmo genprintval.cmo
+LIBINCLUDES=-I $(OCAMLROOT)/parsing \
+ -I $(OCAMLROOT)/typing \
+ -I $(OCAMLROOT)/toplevel \
+ -I $(OCAMLROOT)/utils
+
+# METANATIVE=ident.cmx utils/misc.cmx utils/tbl.cmx utils/config.cmx \
+# utils/consistbl.cmx \
+# utils/clflags.cmx utils/terminfo.cmx utils/ccomp.cmx utils/warnings.cmx \
+# parsing/linenum.cmx parsing/location.cmx parsing/longident.cmx \
+# parsing/syntaxerr.cmx parsing/parser.cmx \
+# parsing/lexer.cmx parsing/parse.cmx parsing/printast.cmx \
+# typing/path.cmx \
+# typing/primitive.cmx typing/types.cmx \
+# typing/btype.cmx \
+# typing/subst.cmx typing/predef.cmx \
+# typing/datarepr.cmx typing/env.cmx \
+# typing/typedtree.cmx typing/ctype.cmx \
+# typing/oprint.cmx typing/printtyp.cmx typing/includeclass.cmx \
+# typing/mtype.cmx typing/includecore.cmx \
+# typing/includemod.cmx typing/parmatch.cmx \
+# typing/typetexp.cmx typing/stypes.cmx typing/typecore.cmx \
+# typing/typedecl.cmx typing/typeclass.cmx \
+# typing/typemod.cmx \
+# bytecomp/lambda.cmx bytecomp/printlambda.cmx \
+# bytecomp/typeopt.cmx bytecomp/switch.cmx bytecomp/matching.cmx \
+# bytecomp/cprint.cmx bytecomp/f90abs.cmx bytecomp/cabs.cmx bytecomp/dl.cmx \
+# bytecomp/trxtime.cmx bytecomp/trx.cmx \
+# bytecomp/translobj.cmx bytecomp/translcore.cmx \
+# bytecomp/translclass.cmx bytecomp/translmod.cmx \
+# bytecomp/simplif.cmx bytecomp/runtimedef.cmx \
+# asmcomp/arch.cmx asmcomp/cmm.cmx asmcomp/printcmm.cmx \
+# asmcomp/reg.cmx asmcomp/mach.cmx asmcomp/proc.cmx \
+# asmcomp/clambda.cmx asmcomp/compilenv.cmx \
+# asmcomp/closure.cmx asmcomp/cmmgen.cmx \
+# asmcomp/printmach.cmx asmcomp/selectgen.cmx asmcomp/selection.cmx \
+# asmcomp/comballoc.cmx asmcomp/liveness.cmx \
+# asmcomp/spill.cmx asmcomp/split.cmx \
+# asmcomp/interf.cmx asmcomp/coloring.cmx \
+# asmcomp/reloadgen.cmx asmcomp/reload.cmx \
+# asmcomp/printlinear.cmx asmcomp/linearize.cmx \
+# asmcomp/schedgen.cmx asmcomp/scheduling.cmx \
+# asmcomp/emitaux.cmx asmcomp/emit.cmx asmcomp/asmgen.cmx \
+# asmcomp/asmlink.cmx asmcomp/asmlibrarian.cmx asmcomp/asmpackager.cmx \
+# unused_var.cmx \
+# driver/pparse.cmx driver/opterrors.cmx driver/optcompile.cmx \
+# natdyn/natdynlink.cmx\
+# stdlib/hookdynlink.cmx
+
+
+gprint.cma: gprint.ml gprint.cmi
+ $(OCAMLC) $(LIBINCLUDES) -o $@ -a $(LIBLIBMOD) gprint.ml
+
+# gprint.cmxa: gprint.ml gprint.cmi
+# $(MOCAMLOPTC) $(LIBINCLUDES) -I $(OCAMLROOT) -o $@ -a $(METANATIVE) \
+# $(OCAMLROOT)/toplevel/genprintval.ml \
+# gprint.ml
+
+# .PHONY: test_toponly
+# test_toponly:
+# (sed "s?/home/oleg/Cache/ometa-cvs?$(OCAMLROOT)?g" gprint_toplevel.ml;\
+# sed "s?open Gprint?open Format?g" vgprint.ml) | \
+# $(OCAMLTOP)
+
+# testb: gprint.cma gprint.cmi vgprint.ml
+# $(OCAMLC) -o $@ gprint.cma vgprint.ml
+# ./$@
+
+vgprint_top: vgprint_aux.cmi
+ $(MOCAMLTOP) vgprint.ml
+
+vgprint: vgprint_aux.cmi
+ $(MOCAMLC) -o $@ vgprint.ml
+ ./vgprint
+
+clean::
+ rm -f testb vgprint
+
+# testo: gprint.cmxa gprint.cmi vgprint.ml
+# $(MOCAMLOPTC) -o $@ gprint.cmxa \
+# hookdynlink.cmx -ccopt -Wl,-E -cclib -lnatdyn vgprint.ml
+# ./$@
+
+clean::
+ rm -f testo
+
+clean::
+ rm -f *.cm[io] *.[oa] *~
diff -Naur ocaml-4.02.1/metalib/gprint/vgprint_aux.ml ocaml-ber-n102/metalib/gprint/vgprint_aux.ml
--- ocaml-4.02.1/metalib/gprint/vgprint_aux.ml 1970-01-01 01:00:00.000000000 +0100
+++ ocaml-ber-n102/metalib/gprint/vgprint_aux.ml 2015-01-10 16:27:06.936030975 +0000
@@ -0,0 +1,13 @@
+(*
+ Declaration of a simple variant type, to be used in the main
+ test file vgprint.ml
+
+ The goal is to test gprint of values whose types are declared
+ in other files. To be precise, we test the proper setting of the
+ load_path, needed to locate .cmi files with declarations for
+ the types of the values being printed.
+
+ This test has been proposed by Tran Minh Quang.
+*)
+
+type ext = T1 of int | T2 of string option
diff -Naur ocaml-4.02.1/metalib/gprint/vgprint.ml ocaml-ber-n102/metalib/gprint/vgprint.ml
--- ocaml-4.02.1/metalib/gprint/vgprint.ml 1970-01-01 01:00:00.000000000 +0100
+++ ocaml-ber-n102/metalib/gprint/vgprint.ml 2015-01-10 16:27:06.936030975 +0000
@@ -0,0 +1,89 @@
+(** Generic print
+
+Test code.
+
+$Id: vgprint.ml,v 1.1 2006/04/15 11:27:37 oleg Exp $
+*)
+
+open Gprint;;
+
+let pr_type et = Format.printf "\n%s@." et
+
+let () = pr_type (print .<1>.)
+;;
+
+
+let () = pr_type (let x = 1 in print .<x>.);;
+
+let () = pr_type (print .<10.0>.)
+;;
+
+let () = pr_type (print .<"xxx">.)
+;;
+
+let () = pr_type (let x = Some ([|(10,true);(11,false)|]) in print .<x>.);;
+
+module C = struct
+ type 'a color = Blue | Green | Rgb of 'a
+end;;
+
+type 'a image = {title : string; pixels : 'a C.color array};;
+type big = int image list;;
+
+let v = [
+ {title = "im1";
+ pixels = [| C.Blue; C.Rgb 10 |]};
+ {title = "im2";
+ pixels = [| C.Green |]};
+] ;;
+
+let () = pr_type (print .<v>.)
+;;
+
+(* current drawback due to the lack of integration, and the work-around*)
+let foo (x : int option) = print .<x>. in pr_type (foo None );;
+
+let foo (x : int option) = print (let z = [x] in .<z>.) in pr_type (foo None);;
+
+
+(* Now we open C *)
+open C
+
+let some_processing ims =
+ let brighten px =
+ let new_px = match px with
+ Blue -> Green
+ | Green -> Rgb 10
+ | Rgb x -> Rgb (x+1) in
+ let () = Format.printf "@.pixel: %a -> %a @."
+ (fun ppf v -> ignore (fprint ppf v))
+ (let x = [px] in .<x>.)
+ (fun ppf v -> ignore (fprint ppf v))
+ (let x = [new_px] in .<x>.) in
+ new_px in
+ let process im =
+ let () = Format.printf "Processing: " in
+ let _ = print .<im>. in
+ {im with pixels = Array.map brighten im.pixels} in
+ let res = List.map process ims in
+ let _ = print .<res>. in
+ Format.printf "@."
+;;
+
+let () = some_processing v;;
+
+
+(* This test gprint-ing of values whose type has been declared
+ in other files. In other words, we test locating .cmi files
+ at the type of gprint.
+
+ This test has been proposed by Tran Minh Quang.
+*)
+
+let extv = Vgprint_aux.T2 (Some "extv");;
+
+let () = pr_type (print .<extv>.)
+;;
+
+print_endline "\nAll done"
+;;
diff -Naur ocaml-4.02.1/metalib/INSTALL ocaml-ber-n102/metalib/INSTALL
--- ocaml-4.02.1/metalib/INSTALL 1970-01-01 01:00:00.000000000 +0100
+++ ocaml-ber-n102/metalib/INSTALL 2015-01-10 16:27:06.936030975 +0000
@@ -0,0 +1,68 @@
+INSTALLATION
+
+You need the source OCaml 4.02.1 distribution, which you can download from
+ http://caml.inria.fr/download.en.html
+See also
+ http://ocaml.org/install.html
+
+1. Download, un-tar the OCaml distribution and configure it as described
+ in its INSTALL file
+
+ For example, in the OCaml distribution directory, do
+
+ ./configure -prefix `pwd` -no-pthread -no-graph
+
+ You may chose any other installation prefix. It is best however
+ to chose the prefix different from that of the standard OCaml installation,
+ so to keep the existing OCaml installation intact.
+
+1a. Update the Makefile in the ber-metaocaml directory
+
+ change CAMLROOT= at the beginning of the ber-metaocaml/Makefile
+ to point to the OCaml distribution directory
+
+2. Patch the OCaml distribution
+
+ In the ber-metaocaml directory, do
+
+ make patch
+
+
+3. Compile and install OCaml as usual. For example, in the OCaml
+ distribution directory, do
+
+ make world
+ make -i install
+
+
+4. Build the BER MetaOCaml library, the top-level, and the
+ compilation script
+
+ In the ber-metaocaml directory, do
+
+ make all
+ make install
+
+ The BER MetaOCaml top-level can be started afterwards as
+ $prefix/bin/metaocaml
+
+ The batch compiler can be run using the command file metaocamlc.
+
+5. Optionally run sample tests
+
+ In the ber-metaocaml directory, do
+
+ make test
+ make test-compile
+
+
+Installation of BER MetaOCaml on Windows has not been tested. Original
+MetaOCaml contained the following note about the Windows platform:
+
+ To use MetaOCaml under MS Windows, please do not use "Windows
+ OCaml". Rather, use the standard OCaml system under cygwin. If you
+ happened to install the "Windows OCaml" in the past, manually remove
+ some environment variables before you can install the standard system
+ successfully. To do that, goto START -> Control Panel -> System ->
+ Advanced -> Environment variables, and edit the OCAMLLIB variable and
+ remove any entries in that entry.
diff -Naur ocaml-4.02.1/metalib/Makefile ocaml-ber-n102/metalib/Makefile
--- ocaml-4.02.1/metalib/Makefile 1970-01-01 01:00:00.000000000 +0100
+++ ocaml-ber-n102/metalib/Makefile 2015-01-10 16:27:06.936030975 +0000
@@ -0,0 +1,142 @@
+# Build the BER MetaOCaml library, top-level, and the compiler driver
+# See INSTALL for more detail
+
+# Location of the OCaml distribution directory
+CAMLROOT=..
+
+include $(CAMLROOT)/config/Makefile
+
+RUNTIME=$(CAMLROOT)/boot/ocamlrun
+INCLUDES=-I $(CAMLROOT)/utils \
+ -I $(CAMLROOT)/parsing -I $(CAMLROOT)/typing -I $(CAMLROOT)/bytecomp \
+ -I $(CAMLROOT)/asmcomp -I $(CAMLROOT)/driver \
+ -I $(CAMLROOT)/toplevel -I $(CAMLROOT)/stdlib
+COMPILER=$(CAMLROOT)/ocamlc
+CAMLC=$(RUNTIME) $(COMPILER) $(INCLUDES)
+COMPFLAGS=-strict-sequence -w +33..39 -warn-error A -nostdlib
+OPTCOMPILER=$(CAMLROOT)/ocamlopt
+CAMLOPT=$(RUNTIME) $(OPTCOMPILER)
+OPTCOMPFLAGS=-strict-sequence -w +33..39 -warn-error A -nostdlib
+CAMLDEP=$(CAMLROOT)/boot/ocamlrun $(CAMLROOT)/tools/ocamldep
+
+METALIB=metalib.cma
+METALIBOBJS=runcode.cmo print_code.cmo
+METAOBJS=$(METALIB) bertop.cmo berstart.cmo
+
+all: $(METAOBJS) metaocaml metaocamlc
+
+.SUFFIXES: .mli .ml .cmi .cmo .cmx
+
+.mli.cmi:
+ $(CAMLC) $(COMPFLAGS) -c $<
+
+.ml.cmo:
+ $(CAMLC) $(COMPFLAGS) -c $<
+
+.ml.cmx:
+ $(CAMLOPT) $(OPTCOMPFLAGS) -c $<
+
+$(METALIB): $(METALIBOBJS)
+ $(CAMLC) $(COMPFLAGS) -o $@ -a $(METALIBOBJS)
+
+
+install: metaocaml metaocamlmktop metaocamlc
+ cp runcode.cmi print_code.cmi metalib.cma bertop.cmo berstart.cmo \
+ $(LIBDIR)
+ cp metaocaml $(BINDIR)/metaocaml$(EXE)
+ cp metaocamlmktop $(BINDIR)/metaocamlmktop$(EXE)
+ cp metaocamlc $(BINDIR)/metaocamlc$(EXE)
+
+metaocaml: $(METAOBJS) $(CAMLROOT)/compilerlibs/ocamlcommon.cma
+# $(CAMLROOT)/tools/ocamlmktop \
+# -o $@ $(METALIB) bertop.cmo berstart.cmo
+ $(CAMLC) -nostdlib -linkall \
+ $(CAMLROOT)/compilerlibs/ocamlcommon.cma \
+ $(CAMLROOT)/compilerlibs/ocamlbytecomp.cma \
+ $(CAMLROOT)/compilerlibs/ocamltoplevel.cma \
+ -o $@ $(METALIB) bertop.cmo berstart.cmo \
+ $(CAMLROOT)/toplevel/topstart.cmo
+
+
+
+clean::
+ rm -f metaocaml
+
+metaocamlmktop: metaocamlmktop.tpl metaocaml
+ sed -e 's|%%BINDIR%%|$(BINDIR)|' metaocamlmktop.tpl > metaocamlmktop
+ chmod +x metaocamlmktop
+
+clean::
+ rm -f metaocamlmktop
+
+metaocamlc: metaocamlc.c
+ $(CC) -Wall -DBINDIR=\"$(BINDIR)\" -o metaocamlc metaocamlc.c
+
+clean::
+ rm -f metaocamlc
+
+clean::
+ rm -f *.cm* *.o *.a
+ rm -f test/*.cm* test/*.o
+ rm -f *~
+# cd gprint && $(MAKE) CAMLROOT=../$(CAMLROOT) clean
+
+test:
+ TERM=dumb $(BINDIR)/metaocaml -w -8 < test/trivial.ml > trivial.out && \
+ diff -u trivial.out trivial.ref
+ TERM=dumb $(BINDIR)/metaocaml -w -8 < test/simple.ml > simple.out && \
+ diff -u simple.out simple.ref
+ $(BINDIR)/metaocaml -w -8 test/simple_true.ml
+ $(BINDIR)/metaocaml -w -8 test/quick_test.ml
+ $(BINDIR)/metaocaml -w -8 test/test21.ml
+ $(BINDIR)/metaocaml -w -8 test/pythagorian_triples.ml
+ $(BINDIR)/metaocaml -w -8 test/test_levels.ml
+# $(BINDIR)/metaocaml test/t4.ml
+# cd gprint && $(MAKE) CAMLROOT=../$(CAMLROOT) MOCAMLTOP="../metaocaml -I .." testv_top
+# cd gprint && $(MAKE) CAMLROOT=../$(CAMLROOT) vgprint_top
+
+test-compile:
+ $(BINDIR)/metaocamlc -w -8 -o simple_true test/simple_true.ml
+ ./simple_true
+# $(BINDIR)/metaocamlc -o quick_test test/quick_test.ml
+# ./quick_test
+ $(BINDIR)/metaocamlc -dparsetree -drawlambda -dinstr -c test/test21.ml
+ $(BINDIR)/metaocamlc -c test/t4types.mli && \
+ cp test/t4types.cmi . # .cmi file should be where the executable is
+ $(BINDIR)/metaocamlc -w -8 -o t4 -I test/ test/t4.ml
+ ./t4
+ $(BINDIR)/metaocamlc -o pt test/pythagorian_triples.ml
+ ./pt
+# cd gprint && $(MAKE) CAMLROOT=../$(CAMLROOT) vgprint
+# Testing setting of the .cmo path
+ $(BINDIR)/metaocamlc test/test_path_a.ml
+ mv test/test_path_a.cm[io] /tmp
+ $(BINDIR)/metaocamlc -I /tmp -o tp test/test_path.ml
+ ./tp
+
+clean::
+ rm -f simple_true quick_test t4 pt trivial.out simple.out a.out tp
+
+# Patch the OCaml distribution
+patch:
+ cp -p patches/trx.ml $(CAMLROOT)/typing/
+ cp -p patches/trx.mli $(CAMLROOT)/typing/
+# patch -p0 -d $(CAMLROOT) < patches/patch
+ patch -p1 -d $(CAMLROOT) < patches/patch
+
+# Create the patch set
+makepatch:
+ cp -p $(CAMLROOT)/typing/trx.ml patches/
+ cp -p $(CAMLROOT)/typing/trx.mli patches/
+ sh ./build_patch.sh > patches/patch
+
+# metaocamlopt: stdlib/metanative.cmxa tools/metaocamlopt.tpl
+# sed -e 's|%%BINDIR%%|$(BINDIR)|' tools/metaocamlopt.tpl > metaocamlopt
+# chmod +x metaocamlopt
+
+include .depend
+
+depend:
+ $(CAMLDEP) *.mli *.ml > .depend
+
+.PHONY: all test clean patch makepatch depend test-compile install
diff -Naur ocaml-4.02.1/metalib/make_metalib.sh ocaml-ber-n102/metalib/make_metalib.sh
--- ocaml-4.02.1/metalib/make_metalib.sh 1970-01-01 01:00:00.000000000 +0100
+++ ocaml-ber-n102/metalib/make_metalib.sh 2015-01-10 16:27:06.936030975 +0000
@@ -0,0 +1,39 @@
+# Make the distribution directory
+
+DEST=/tmp/ber-metaocaml-102
+
+mkdir $DEST
+
+cp -p \
+.depend \
+ChangeLog \
+Files.txt \
+INSTALL \
+Makefile \
+NOTES.txt \
+ORIGINAL-LICENSE-META \
+Problems.txt \
+README \
+berstart.ml \
+bertop.ml \
+build_patch.sh \
+metaocamlmktop.tpl \
+metaocamlc.c \
+print_code.ml \
+print_code.mli \
+runcode.ml \
+runcode.mli \
+simple.ref \
+trivial.ref \
+$DEST/
+
+mkdir $DEST/patches
+cp -p patches/* $DEST/patches
+
+mkdir $DEST/test
+cp -p test/*.ml test/*.mli $DEST/test
+
+# mkdir $DEST/gprint
+# cp -p gprint/Makefile $DEST/gprint
+# cp -p gprint/*.ml $DEST/gprint
+# cp -p gprint/*.mli $DEST/gprint
diff -Naur ocaml-4.02.1/metalib/metaocamlc.c ocaml-ber-n102/metalib/metaocamlc.c
--- ocaml-4.02.1/metalib/metaocamlc.c 1970-01-01 01:00:00.000000000 +0100
+++ ocaml-ber-n102/metalib/metaocamlc.c 2015-01-10 16:27:06.936030975 +0000
@@ -0,0 +1,75 @@
+/* A small glue file to compile MetaOCaml code
+
+ All the compilation is done by the patched ocamlc, and this program
+ merely executes it.
+
+ The purpose of this program is to set program options
+ to add compiler-libs/ and the compiler libraries -- but only when
+ we link the final executable. Otherwise,
+ the final executable ends up with two copies of the compiler libraries,
+ and this is the disaster, leading to sigfaults (because the the compiler
+ librtaries, esp. env, are stateful).
+
+ This program expects the preprocessor flag -DBINDIR for the path to ocamlc.
+*/
+
+
+#if !defined(BINDIR)
+#error "Define BINDIR, as -DBINDIR=\"path-to-ocaml-bin-directory\""
+#endif
+
+#include <stdlib.h>
+#include <string.h>
+#include <assert.h>
+#include <unistd.h>
+#include <stdio.h>
+
+static char path_ocamlc [] = BINDIR "/ocamlc";
+
+/* New flags that we prepend to the command line */
+static char *const metaocaml_extra_flags [] = {
+ "-I", "+compiler-libs",
+ "ocamlcommon.cma",
+ "ocamlbytecomp.cma",
+ "ocamltoplevel.cma",
+ "metalib.cma",
+ "berstart.cmo"
+ };
+
+/* Flags that prevent building the executable */
+static char *const nonlinking_flags [] = {
+ "-c", "-pack", "-a", "-output-obj"
+ };
+
+/* Check to see that we are invoked to build the executable */
+static int is_linking(char * const argv[])
+{
+ int i,j;
+ for(i=1; argv[i]; i++) /* argv is NULL-terminated */
+ for(j=0; j<sizeof(nonlinking_flags)/sizeof(nonlinking_flags[0]); j++)
+ if(strcmp(argv[i], nonlinking_flags[j]) == 0)
+ return 0;
+ return 1;
+}
+
+int main(int argc, char *const argv[],char *const envp[])
+{
+ char *const * new_argv = argv;
+
+ if( is_linking(argv) ) {
+ char **p;
+ const int argv_len = argc+1; /* counting the NULL at the end of argv */
+ const int extra_flags_len = sizeof(metaocaml_extra_flags)/
+ sizeof(metaocaml_extra_flags[0]);
+ assert(new_argv=calloc(argv_len+extra_flags_len,sizeof(argv[0])));
+ p = (char **)new_argv;
+ *p++ = argv[0];
+ memcpy(p,metaocaml_extra_flags,extra_flags_len*sizeof(argv[0]));
+ p += extra_flags_len;
+ memcpy(p,&argv[1],(argv_len-1)*sizeof(argv[0]));
+ }
+
+ execve(path_ocamlc,new_argv,envp); /* Does not normally return */
+ perror("execve failed, perhaps wrong path to ocamlc");
+ exit(2);
+}
diff -Naur ocaml-4.02.1/metalib/metaocamlmktop.tpl ocaml-ber-n102/metalib/metaocamlmktop.tpl
--- ocaml-4.02.1/metalib/metaocamlmktop.tpl 1970-01-01 01:00:00.000000000 +0100
+++ ocaml-ber-n102/metalib/metaocamlmktop.tpl 2015-01-10 16:27:06.936030975 +0000
@@ -0,0 +1,16 @@
+#!/bin/sh
+#########################################################################
+# #
+# OCaml #
+# #
+# Damien Doligez, projet Para, INRIA Rocquencourt #
+# #
+# Copyright 1999 Institut National de Recherche en Informatique et #
+# en Automatique. All rights reserved. This file is distributed #
+# under the terms of the Q Public License version 1.0. #
+# #
+#########################################################################
+
+# $Id$
+
+exec %%BINDIR%%/ocamlc -I +compiler-libs -linkall ocamlcommon.cma ocamlbytecomp.cma ocamltoplevel.cma metalib.cma bertop.cmo berstart.cmo "$@" topstart.cmo
diff -Naur ocaml-4.02.1/metalib/metatop.mli ocaml-ber-n102/metalib/metatop.mli
--- ocaml-4.02.1/metalib/metatop.mli 1970-01-01 01:00:00.000000000 +0100
+++ ocaml-ber-n102/metalib/metatop.mli 2015-01-10 16:27:06.936030975 +0000
@@ -0,0 +1,3 @@
+(* `Plugin' for the OCaml top-level *)
+
+
diff -Naur ocaml-4.02.1/metalib/NOTES.txt ocaml-ber-n102/metalib/NOTES.txt
--- ocaml-4.02.1/metalib/NOTES.txt 1970-01-01 01:00:00.000000000 +0100
+++ ocaml-ber-n102/metalib/NOTES.txt 2015-01-10 16:27:06.936030975 +0000
@@ -0,0 +1,870 @@
+ BER MetaOCaml
+
+
+* Main differences from the original MetaOCaml
+
+
+** Substantial changes, user-visible
+ -- New function Runcode.typecheck_code for the benefit of offshoring
+
+ -- New function Runcode.add_search_path to add a directory to
+ the search path for .cmi/.cmo files -- report by Nicolas Ojeda Bar
+
+ -- better printing of CSP; CSP become serializable in simpler cases
+ (see a special section on CSP below)
+
+ [N101]
+ -- Constructor restriction: all data constructors and record labels
+ used within brackets must come from the types that are declared in
+ separately compiled modules.
+
+ -- Scope extrusion check: attempting to build code values with
+ unbound or mistakenly bound variables (which is possible with
+ mutation or other effects) is caught early, raising an exception
+ with good diagnostics.
+
+ -- The scope extrusion check made it possible to remove environment
+ classifiers while still preserving the static guarantee: if the generator
+ finishes successfully, the generated code is well-typed and
+ well-scoped. Environment classifiers ensured well-scopedness when
+ type-checking the generator -- but only for pure generators. The
+ scope extrusion check is executed when the generator is run; however
+ the check is now comprehensive. Scope extrusion is always caught, and
+ caught early, whether the generator is effectful or not.
+
+ -- Syntax .! is replaced with the ordinary prefix operation
+ (!.) (alias run) defined in the module Runcode. Runcode.run is an
+ ordinary function, and is not part of the MetaOCaml kernel.
+
+
+** Substantial changes, internal
+
+-- Use attributes for bracket and escape.
+ Why not extension nodes: the type checker ignores extension nodes
+ (or reports them as errors) at many places (for example, when
+ traversing the AST to find free variables; when checking for
+ non-expansiveness, etc). But nodes with attributes are treated
+ normally, which is exactly what we want.
+
+So, .< exp >. is represented as
+ exp [@metaocaml.bracket]
+or
+ begin[@metaocaml.bracket] exp end
+Likewise, .~exp is represented as
+ exp [@metaocaml.escape]
+
+Keep in mind that an expression can have several bracket and escape
+attributes, for example: .<.<1>.>.
+The order matters: .<.< .~ x >.>. vs .< .~.<x>. >.
+
+-- Now metaocamlc a simple .c file that invokes ocamlc
+after setting adding up compiler libraries and berstart.cmo --
+but only if we link the executable. If metaocamlc is invoked to
+compile only or to build a library, don't add compiler libraries and
+berstart. Otherwise, when we get to make the final executable, we end
+up with duplicate compiler libraries, and this is the disaster
+(segfault).
+
+-- We now avoid the extra translation pass. The type-checker
+should invoke the trx_bracket after type-checking the bracket at level
+0. Therefore, if there are no staging constructs, the typedtree is
+not traversed at all after type checking. Typemod.ml no longer has to
+be modified.
+However, we pay the price: the check on non-epxansiveness is done
+on the type-checked expression. So, we have to arrange so that we
+check if an expression is non-expansive before the translation.
+We carry this information in the dedicated attribute.
+
+-- Instead of the Level environment, carry the level as the attribute
+to the value, in value attributes.
+
+-- Taking advantage of the extensible error-reporting mechanism
+provided by Location.register_error_of_exn.
+
+[N101]
+ -- In OCaml 4.00.1 , the Core type checker was changed to use
+ type_expect. This generates better error messages. Therefore, the type
+ checking of brackets, escape and CSP was re-written accordingly,
+ to propagate expectations down. For example, <e> is expected to have
+ the type of ty code where e has is expected to have the
+ type ty.
+
+ -- The main MetaOCaml kernel module, trx.ml, has been completely
+ re-written. Many algorithms were changed. For example, the traversal
+ of the Typedtree looking for brackets to replace is completely
+ re-written. Now we maintain sharing as much as possible. If the tree
+ has no brackets, it is returned as it was. Previously, it was copied.
+
+ -- Faster generation of code (especially for functions and nonbinding
+ functions)
+
+ -- Added a test for the well-formedness of recursive let (see below)
+
+ -- Applications with labeled arguments are supported now.
+
+ -- The problem with first-class polymorphism (records with polymorphic
+ fields inside brackets) has fixed itself. See the file
+ tests/simple.txt.
+
+
+ -- Precise type assignment when building Typedtree nodes (when
+ hand-compiling Parsetree generation)
+
+ -- Processing of CSP has changed, split into two phases. At
+ compilation time, we know the type of the CSP and decide if values
+ of that type can be lifted. If not, we look at the CSP identifier
+ to decide if the CSP can be referred to by qualified name (that is,
+ the CSP identifier is part of a separately compiled module).
+ If all fails, we generate the call to a quotator that would build
+ the CSP at run-time, when the value to quote becomes known. Overall,
+ the procedure improves the printing of CSP.
+
+
+** Separation into `kernel' and `user-level' code
+
+The kernel modifies (and is part of) the OCaml system. The user-level
+code is in a directory metalib outside the OCaml distribution. The
+user-level code can be changed and expanded without the need to hack
+and re-compile (Meta)OCaml. Changes introduced to future versions of
+OCaml will not generally affect the `user-level' code.
+
+ -- Printing of code values -- AST pretty_printing by Ed Pizzi --
+ is moved to user-level, a dedicated file metalib/print_code.ml.
+ The bulk of pretty-printing is now done by OCaml itself, module
+ Pprintast.
+
+ -- New API for running code, encouraging the development of new ways
+ to execute code values (see metalib/runcode.mli).
+ The operation 'run' is a regular function now, and is user-level
+ rather than being part of the kernel.
+
+ -- Now BER MetaOCaml is built as a custom top-level, using the standard tool
+ ocamlmktop. We register code printers as regular top-level printers
+ of user-defined data types. Therefore, topmain is no longer modified.
+
+ -- Tag elimination is fully removed.
+
+ -- trxtime is moved to metalib.
+
+ -- Offshoring is temporarily removed; it should be re-introduced as
+ a module in metalib, a user-level code.
+
+** Better handling of CSP in N102
+
+There is no longer any specific node for CSP. We do not need them:
+old CSP nodes are represented as an application (Obj.obj <csp-val>).
+Since the CSP nodes are assumed type-checked, we get around typing --
+as we did before with the PExp_csp node. Obj.obj serves exactly the
+same purpose.
+A better design: if CSP is represented as an integer, we compile
+CSP v as if it were .<Obj.obj .~(Obj.repr v)>..
+If Obj.repr is block (a heap value), presently we compile it as
+the same. However, in the future we should do
+.<Marshall.from_string .~(Marshall.to_string v)>.
+(perhaps with the flags to preserve sharing and permit marshaling of
+functional values). We attach the attribute carrying the name of the
+CSP variable, for the sake of pretty-printing functions
+(They may want to print that name in the comments). Finally we get the
+output format that is compilable even in the presence of CSP.
+To estimate when to switch to the new format, the dyn_quoter now
+checks the CSP to and prints a warning if the CSP is a closure or
+if it is ``too deep''.
+
+Better printing of CSP; now in simple cases CSP are serializable
+and hence present no problems.
+let l x = .<x>.;; (* polymorphic *)
+l 1;;
+ - : int code = .<(* CSP x *) Obj.magic 1>.
+l 1.0;; (* better printing in N100 *)
+ - : float code = .<1.>.
+l [];; (* serializable code in N102 *)
+ - : 'a list code = .<(* CSP x *) Obj.magic 0>.
+
+In any case, CSPs that are used by the MetaOCaml itself (for the
+Parsetree fragments) are already in the new format. Therefore,
+metaocaml (the compiler itself) can be natively compiled.
+Observation: most of the serialized values are of the size 50. It
+seems the minimal size is about 42, the size of the header for the
+serialized value. When dealing with functions, case matching, some
+serialized values (patterns, pattern lists) could be about 70 or even
+150. It seems I should write my own serializer, that avoids the
+overhead of Marshall. I should use it when the value is not too deep,
+or internally for MetaOCaml CSP.
+
+** Engineering changes
+
+ -- All modified lines in the OCaml code are marked by (* NNN *)
+
+ -- There are comments now -- and lots of them
+
+ -- Added very many regression tests (which also work as examples) to test
+ every feature: see test/trivial.ml and test/simple.ml
+
+ -- The new BER N101 is not only source-compatible with OCaml 4.01 --
+ it is also binary compatible. Any 4.01-built OCaml library and plugin
+ (including findlib) can be used with BER N101 in their binary form.
+ The building of BER N101 no longer involves bootstrapping
+ and is hence much faster.
+
+
+
+* What part of MetaOCaml can be moved to the OCaml proper
+Suggestions for the OCaml HQ
+
+ -- make all path_idents in predef.ml to be persistent. Currently,
+ to check if type int is in Pervasives, I have to search the initial
+ environment.
+
+ -- There are two restrictions on let rec: patterns must be simple
+ variable patterns (either just 'var' or '_ as var') and the variable
+ bound by let rec must appear under lambda, lazy or constructor.
+ These conditions are checked very late (in bytecomp/transcore.ml),
+ after type checking. But these are syntactic conditions; in
+ particular, the first condition can be checked during the parsing.
+ Minimal suggestion: check the first condition at parsing and
+ the second at type checking. So, a code that type checks should
+ produce no further compilation errors. Extended suggestion: since
+ let rec patterns are so restricted (and since the processing of patterns
+ becomes more involved with the addition of GADTs), separate
+ Pexp_let/Texp_let into Pexp_let and Pexp_letrec (ditto for Texp).
+ Type checking will become more orthogonal since in type checking Pexp_letrec
+ we don't need to care about GADTs, the exhaustiveness check and
+ the type propagation from expression to patterns.
+[reported on Mantis, Dec 29, 2014]
+
+ -- Unify printing functions for various trees and make them
+ prettier. The very same fmt_longident_aux occurs three times in
+ the OCaml code base (parsing/printast.ml, tools/pprintast.ml,
+ typing/printtyped.ml)
+
+
+ -- On one hand, it is tempting to eliminate Const_csp_value. There
+ will no longer be a need to modify the code generator (in bytecomp/).
+ On the other hand, Const_csp_value does make sense as a structured
+ constant. Consider a constant that refers to a big array, or even
+ array in ancient. Representing such constant in a Parsetree as a
+ string is ungainly. Syntactic extensions in particular could use
+ Const_csp_value.
+ Feature request: new constant type, structure constant (like block
+ constant in IR lambda). It must be used with a type coercion.
+ The code generator makes a cursory check that the structure agrees
+ with the defined type. To be precise, we want
+ Const_structural Obj.t (* or structural const from Lambda *)
+ * core_type
+
+
+* Further plans
+
+** Optimize the construction of code values (Parsetree)
+
+When the bracket expression is run, it produces the Parsetree that
+represents the code. The tree is constructed at run-time. In some
+cases the Parsetree can be constructed at compile time, in
+trx.ml. A constant like <1> is such a case, when we can immediately
+construct the Parsetree: Pexp_constant (Constant_int 1). After we
+construct the Parsetree at compile time, we use CSP to pass it over to
+run-time. When run, the program will use the compiled constant. This
+mechanism of building Parsetree at compile-time whenever possible is
+one of the large differences from the previous versions of MetaOCaml.
+
+This approach can be extended, by constructing large Parsetree
+subtrees at compile time, and passing them as CSP. See ``TODO: an
+optimization idea. Consider <assert e> as a typical expression.'' in
+trx.ml
+If we can build functions at translation time, we don't even
+need to rename bound variables (let alone do the scope-extrusion
+check). If a code value has no escapes, like .<fun x -> x>.,
+then no scope extrusion is possible.
+
+** Improve processing CSP
+
+When lifting int, bool, etc. values, we generate calls to run-time
+functions like lift_constant_int to do the Parsetree generation. In
+the future we should `inline' those functions -- that is, obtain the
+Typedtree for them and use the tree for building Texp_apply.
+
+Lists, arrays, option types of liftable types are themselves
+liftable. We can lift many more types. For arrays, check their length.
+If the array is short, it should be lifted. For long arrays, building
+a CSP is better (although it make take a bit longer since we will have
+to invoke dyn_quote at run-time).
+
+It seems I should write my own serializer, that avoids the
+overhead of Marshall. I should use it when the value is not too deep,
+or internally for MetaOCaml CSP.
+
+** Minimize changes to OCaml
+
+Strictly speaking, we don't need to change typedtree or parsetree. We
+can just add functions with distinguished names. And add printers and
+add to the type checker. It helps if OCaml added one node to parsetree
+Pexp_extension and a similar node to typed tree. The user may register
+extensions, invoked by the type checker, printer, etc. to type check
+the node.
+
+
+** Search for TODO in trx.ml
+
+** Generating let rec with statically unknown number of bindings
+(suggestion by Jun Inoue)
+Use case: specialization of recursive functions, e.g., specializing
+KMP.
+
+proposed interface
+module MakeLetRecs : sig
+ type letrec_id (* abstract *)
+ val make_letrec : (letrec_id -> ('cl,'w) code) -> ('cl,'w) code
+
+ val add_fun_binding : letrec_id ->
+ (('cl,'a->'b) code -> ('cl,'a->'b) code) ->
+ (('cl,'a->'b) code -> ('cl,'w) code) -> ('cl,'w) code
+end
+
+Perhaps there should also be
+ add_lazy_binding : letrec_id -> ('a lazy code -> 'b lazy code) -> ...
+ (* classifiers omitted *)
+i.e. one that generates bindings of the form
+ a = lazy (foo a)
+
+Jun Inoue wrote:
+I wonder if it wouldn't be too limiting to restrict the interface
+slightly further, so as to ensure that we never get a "this kind of
+expression is not allowed on the right-hand side of a let rec" error?
+For instance, add_fun_binding could be restricted so that
+ add_fun_binding : letrec_id -> (('arg -> 'ret) code -> 'arg code ->
+'ret code) -> (('arg -> 'ret) code -> 'body code) -> 'body code
+and
+ add_fun_binding id (fun f x -> .<.~f .~x>.) (fun f -> .<.~f 0>.)
+produces
+ .<let rec f x = f x in f 0>.
+
+
+
+* Installation notes
+
+configuration line
+OLD (before N102)
+./configure -prefix /home/oleg/Cache/ncaml4/ -no-tk -no-pthread
+-no-camlp4 -no-graph
+
+N102
+./configure -prefix /home/oleg/Cache/ncaml4/ -no-debugger
+ -no-ocamlbuild -no-graph
+
+Use -dtypedtree option on the top level to see the generated tree.
+
+
+* Old Future work
+
+** Get rid of .! as a kernel form
+
+The syntax .! may remain, but only as syntax. The parser would just
+expand .! x to {Trx.cde = x}. To really run the code, we would write
+ Run.run .! .<1>.
+Incidentally, we can have Run.run_bytecode and Run.run_native.
+Since it is possible now to dynamically load native code into
+bytecode, we can separate the mode of running the generated code
+(bytecode/native) from the mode of running the generator.
+
+We don't have to add the record 'a cde to predef. We can add it to
+Trx. The only drawback is that pretty-printer may print {cde = x} with
+the Trx qualification. But it is easy to adjust the pretty-printer to
+omit the Trx qualification.
+
+[BER N101 removed environment classifiers altogether. Therefore, run
+ became ordinary function and is moved out of the kernel.]
+
+Then BER MetaOCaml becomes BE MetaOCaml?
+
+** without environment classifiers, more programs type check
+let tr7 = .<fun x -> !. x>.;;
+(*
+val tr7 : ('a code -> 'a) code = .<fun x_63 -> Runcode.( !. ) x_63>.
+
+Was:
+Characters 24-25:
+ let tr7 = .<fun x -> !. x>.;;
+ ^
+Error: !. error: 'a not generalizable in ('a, 'b) code
+*)
+But the code was legitimate:
+let 10 = !. tr7 .<10>.;;
+
+BER N101 accepts it and runs.
+
+
+** well-formedness check for let rec
+[This check is implemented in BER N101]
+
+ let rec x = x in x;;
+ ^
+Error: This kind of expression is not allowed as right-hand side of `let rec'
+
+It is not well-formed. But it is well-typed:
+
+let c1 = .<let rec x = x in x>.;;
+ val c1 : ('cl, 'a) code = .<let rec x_142 = x_142 in x_142>.
+
+and it is accepted by all versions of MetaOCaml before N101. It is
+only when we try to compile (that is, run) the generated code, we see
+a problem
+
+.! c1;;
+ Exception: Translcore.Error (_, 1).
+
+
+Once I knew where to look, I found another similar problem:
+
+let c2 = .<let rec [] = [] in []>.;;
+ val c2 : ('cl, 'a list) code = .<let rec [] = [] in []>.
+
+It is well-typed and accepted. Alas,
+
+.! c2;;
+ Exception: Translcore.Error (_, 0).
+
+This problem has existed in MetaOCaml from the very beginning, as far
+as I could see.
+
+The first problem is most troubling. Consider
+
+let t1 x = .<0:: .~x>.;;
+ val t1 : ('cl, int list) code -> ('cl, int list) code = <fun>
+let t2 x = .<if true then 0:: .~x else [1]>.;;
+ val t2 : ('cl, int list) code -> ('cl, int list) code = <fun>
+
+Both t1 and t2 are well-typed and accepted. They have identical types.
+However,
+
+let r = .<let rec x = .~(t1 .<x>.) in 2>. in .!r;;
+ - : int = 2
+
+let r = .<let rec x = .~(t2 .<x>.) in 2>. in .!r;;
+ Exception: Translcore.Error (_, 1).
+
+I was thinking to check that all future-stage letrec are of the form
+ let rec f x1 ... xn = ...
+although this is certainly restrictive since it precludes lazy
+bindings and also the following legitimate code
+
+ type stream = Stream of string * (unit -> stream);;
+ let rec f = Stream ("stream", fun () -> f) in f;;
+Perhaps it may be worth noting the issue and leave it for now?
+
+** Installation notes
+When linking the first time, beware!
+Since we added to predef.ml[i], we have changed the timestamps of the
+pre-defined identifiers and exceptions, and so created inconsistency
+with respect to the bootstrap compiler. So, when compiling the system
+the first time, after applying the patches to OCaml, do
+ make core
+ make coreboot
+ make all
+[This is fixed in N101, which is now binary compatible with OCaml]
+
+** Type-checking of run
+Type-checking of run (in typing/typecore.ml) can be done differently,
+using polymorphic/universally quantified variables (Tpoly/Tunivar)
+
+One may think that we can pre-process the ParseTree before we hand it
+over to the type-checker, replacing Pexp_constant that occurs within
+the brackets with a node Pexp_apply "mk_constant", etc. However, we
+have problems with generalizing second-stage let. Since the let-form
+will be replaced with a function call, generalization won't be
+performed!
+[As of BER N101, this is no longer relevant since there are no
+environment classifiers any more.]
+
+** The problem of the constructor environment (signature)
+
+Why typecore.ml has so many changes.
+A bracket expression .< e >. is typechecked once, then it is turned
+into expression that builds, at run-time, the AST for e. When we run
+the code expression, MetaOCaml type-checks the AST -- essentially
+type-checking e the second time around, at a different level this
+time. The second type-checking certainly occurs in a different
+environment -- specifically, in a different constructor and label
+environment. The constructors and labels that have been in effect when
+e is first type-checked may be re-defined when e is type-checked the
+second time.
+
+Therefore, we remember, in the fields pexp_ext and ppat_ext the typed
+tree of the expression resulting from the original type-checker
+run. When we type-check the expression the second time, we keep the
+constructor descriptors resolved from the first time around (yet we
+re-typecheck the arguments of the record and the constructed
+expression: for the sake of staging constructs and CSP, which are
+demoted. After all, the second type-checking occurs at a different
+level).
+
+Currently, MetaOCaml adds pexp_ext and ppat_ext fields to ParseTree,
+to store ref to the type of the node. We only need this information
+for nodes of the variant and record types (see typecore). We don't
+need to store anything for literals, and other irrelevant nodes.
+Furthermore, we don't need to store anything for records and variants
+that are defined in Pervasives (or stdlib). The next approximation:
+we don't need to store any type information if the type is a
+variant/record defined in another module (that is, qualified with the
+name of another module) -- provided that the corresponding .cmi is
+available at run-time, to the run-time compiler.
+
+What pexp_ext and ppat_ext really need to store? Can they just store
+constructor, labels, probably types and classes (but not values) maps
+from Env.t? (We need to force the maps: they have lazy components).
+We can bracket only expressions: therefore, staged code, when
+typechecked again, cannot modify the constructor, label etc maps
+from the environment. Well, there is always
+ <let module M = struct type foo = Foo ... end in ...>
+but it is not clear if we want to support this.
+
+It would be great to find a way not not add fields to Parsetree such
+as pexp_ext and ppat_ext. The latter causes too many modifications, in
+all the places where such records are constructed. Could we store the
+_ext fields in a parallel map? How to garbage-collect them though? It
+would be great if the only cases where ppat_ext and pext_ext mattered
+where the cases of identifiers (so we can use Lident as a key).
+Incidentally, the type t in env.ml is a collection of various maps.
+Perhaps that's the place to store pexp_ext information for
+identifiers. Here is an idea: Think of replacing pexp_ext and ppat_ext
+with an extra field in location record. Location is almost always used
+as an abstract type. Thus when extending the concrete type of
+Location.t, little code needs to be patched.
+
+Here is the idea how to simplify trx code. As we discussed earlier,
+the code expression produces Parsedtree, which contains only the names
+of the constructors. We need to know the constructor description. In
+the regular type-checking, all this information can be found in the
+environment, placed there by data type declarations. When we invoke
+the type checker at run time (as part of running the code), there are
+no data declarations available. After all, a code expression contains
+only expression rather than declarations. Currently, we stash away the
+whole environment inside the fake parsetree. What we can do: during
+the first type-checking, determine is a particular constructor name is
+pre-defined or user-defined. If a constructor name is not global,
+generate a long identifier of the form Lxxxx.real_name where Lxxxx is
+some random string. Maintain a new environment and store in it the
+association of that Lxxxx with the constructor description (which we
+can get from Env.t). Once we finish type-checking, attach the new env
+as part of the code value; perhaps each code value should have the
+field for the environment for constructor description, exception
+description, label and method description. When we run the code, add
+this associated env to the env of the type-checker. We don't need to
+care of any time-stamps. Since the parsed tree contains unique names
+anyway, like Lxxxxx, there is no chance of name clashes. Perhaps the
+synthesized constructor environment could be saved in the .cmo file
+(along with import and other such data)?
+
+*** A new idea
+
+In general, a code value should be a pair (ParseTree, CtorEnv). An
+escape (splice) should merge the CtorEnv parts. So a code value is a
+closure with respect to a signature for type and data constructors. In
+a sense, lambda-a gives us that, if we consider type declarations as
+let-expressions (lambda-a has big lambda).
+
+Actually, OCaml 3.12 already has a similar facility: local open.
+So, a code value should be a parse tree expression of the form
+ let module M = struct
+ declaration of needed constructors, labels,
+ exceptions
+ let res = <expr>
+ in M.res
+Splice should merge such modules, performing renames in case
+of identically named constructors.
+
+See env.ml (and mtype.ml) for functions to export Env.t as a signature
+(and to merge an old signature with the current Env.t -- open).
+There is code for renaming and qualifying all identifiers by a path.
+So, when we generate the code for bracket, maintain the list of
+constructors used in the code. Then build the declarations.
+
+Since we won't store the env any more (as part of pexp_ext, ppat_ext),
+we don't need the lazy transformation of env.ml and we don't need
+to maintain extra time-stamps (which we currently do). The generated
+code becomes self-contained, with all needed constructors, which
+are explicit -- rather than hidden in *_ext fields.
+
+As the initial approximation, to make porting to OCaml 4, require
+that all constructors to be in separate modules (the corresponding
+.cmi must be available at run-time, and, properly, we should record
+their CRC). Later on, save the needed .cmi as part of the code (for
+native compilation). Later, we eliminate that restriction by
+building proper declarations. [BER MetaOCaml N100 implements this
+idea.]
+
+A code value should be a module, struct type t = ... let term = xxx
+end. That nodule defines all type constructors/types that are used
+within the code, except for the built-ins or pervasives. We should
+define these types along with equalities (sharing constraints) so that
+the code and the main program use consistent types.That solves the
+problem of redeclarations (we introduce a nested struct). Also, we
+automatically obtain the desired property that a code value is a
+closure with respect to the constructor env.
+
+type foo = Foo
+let x = <Foo>
+type bar = Foo
+let y = <Foo>
+
+type foo1 = Foo1
+let x = quote (struct type t1 = foo1 = Foo
+ let res = Foo end)
+
+It has to be a functor, from the env. We rely on contra-variance (env
+may contain many more types), Since the env should only contain
+types, its run-time representation is empty. But splicing is a bit
+more expensive since we have to apply env. All identifiers in the env
+are alpha-renamed to contain the explicit tstamp. The main benefit is
+that we don't need to modify the AST to contain the type env.
+
+An idea for the constructor calculus
+
+Datatype definitions can be represented in System Fw:
+ data T = Foo | Bar
+
+is equivalent to the type T, functions foo :: T and bar :: T and
+the deconstructor T -> w -> w -> w. The body of the program in the scope of
+T can be represented as
+ Lam(t) lam(foo:t) lam(bar:t) lam(decon:forall w. t->w->w) ...
+
+Assume that Lam and lam are special in that they bind `special
+identifiers' (constructors) and that we can evaluate under such
+lam. If c is a special identifier, then c v is a value. (check CRWL; I
+think we don't need to do anything about not-fully-applied
+constructors, which are values anyway.) We need Fw so we can bind
+types of the kind *->*, etc. needed for defining list-like types. The
+main advantage: we don't need to introduce constants, and we get the
+regular scoping, substitution rules. So, constants (constructors) and
+identifiers are pretty much the same, with respect to alpha renaming
+and substitution. That simplifies the calculus as we introduce
+staging.
+
+
+** Other
+Think about moving the predefined type ('a,'b) code from
+typing/predef.ml[i] into trx.mli Do we really need the code type
+predefined? Can we consider it pervasive instead? There would be no
+need to modify typecore to add a special rule to process the code
+type.
+
+A conversation with Chung-chieh Shan brought up another issue:
+generalization is not at all clear staged languages. Consider
+ .<let f = fun x -> x in (f 1, f true)>.
+The code is OK. When we type-check it at level 0, we have to
+type-check the body of the bracket at level 1
+ let f = fun x -> x in (f 1, f true)
+and it is certainly OK, since f is generalizable as being bound to a
+value. Now consider this:
+ .<let f = .~(.<fun x -> x>.) in (f 1, f true)>.
+Is this OK? MetaOCaml says yes. What about
+ .<let f = .~((fun y -> y) .<fun x -> x>.) in (f 1, f true)>.
+Now it does not generalize.
+For a good reason! The following, for example, generalizes
+let lift x = .<x>.;;
+let fff =
+ .<let foo = fun x -> let t = .~(lift (ref [])) in
+ (match !t with [] -> t := [x]; x | [y] -> t := [x]; y) in
+ (foo ("xxx"), foo(true), foo([1,2]))>.;;
+and gives the Bus error. See more description and proposed restriction
+in the file Problems.txt, the entry as of June 11, 2010.
+
+Other interesting cases:
+let id y = y in .<let f = fun x -> id x in (f 1, f true)>.;;
+
+Interesting case:
+let id y = y in .<let f = fun x -> id y in (f 1, f true)>.;;
+let id y = y in .<let f = fun x -> id x in (f 1, f true)>.;;
+
+
+
+* Done in N102 (Dec 2014)
+
+** What part of MetaOCaml can be moved to the OCaml proper
+Suggestions for the OCaml HQ
+
+ - Better and modular error handling. Currently, to add a new
+ error, say, to typecore.ml one has to add the error to typecore.mli,
+ make the same addition to typecore.ml, augment the printing function
+ in typecore.ml. To add a new category, one has to augment
+ driver/errors.ml. I have tried a uniform
+ exception Error of (format -> unit)
+ The error carries the function that will print out the error
+ message on the supplied ppf. Handler becomes much more extensible!
+ This approach does seem to work out. It is used all throughout N101.
+
+OCaml 4.02.1 introduces the modular error handling, by registering
+handlers for specific exceptions. See parsing/location.ml. BER N102
+takes advantage of this facility.
+
+* Done in N004 (Nov 7, 2012)
+Check to see if val_level field in the value_description structure can
+be eliminated. Quite a few patches become unnecessary. We should
+associate the staging level with identifiers rather than values. We
+should introduce a new map in Env.t that maps identifiers to levels.
+Global identifiers and identifiers appearing in structures and
+signatures are not in the domain of that map and are implicitly
+0-level. We don't support module expressions in the staged code.
+
+We have done that.
+
+Adding a new Texp_ident (see typecore etc) should be accompanied by
+Env.add_level ident !global_level But we don't support staging for
+objects.
+
+Before
+
+# let x = 1 in .<x>.;;
+- : ('a, int) code = .<1>.
+# let x = [] in .<x>.;;
+- : ('a, 'b list) code = .<(* cross-stage persistent value (as id: x) *)>.
+# let x = None in .<x>.;;
+- : ('a, 'b option) code = .<(* cross-stage persistent value (as id: x) *)>.
+# let x = "abc" in .<x>.;;
+- : ('a, string) code = .<(* cross-stage persistent value (as id: x) *)>.
+# let x = 123l in .<x>.;;
+- : ('a, int32) code = .<(* cross-stage persistent value (as id: x) *)>.
+
+# .<Array.get>.;;
+- : ('a, 'b array -> int -> 'b) code = .<Array.get>.
+# .<List.nth>.;;
+- : ('a, 'b list -> int -> 'b) code =
+.<(* cross-stage persistent value (as id: List.nth) *)>.
+
+Now
+# let x = 1 in .<x>.;;
+- : ('a, int) code = .<1>.
+# let x = [] in .<x>.;;
+- : ('a, 'b list) code = .<(* cross-stage persistent value (as id: x) *)>.
+# let x = None in .<x>.;;
+- : ('a, 'b option) code = .<(* cross-stage persistent value (as id: x) *)>.
+# let x = "abc" in .<x>.;;
+- : ('a, string) code = .<"abc">.
+# let x = 123l in .<x>.;;
+- : ('a, int32) code = .<123>.
+# .<Array.get>.;;
+X: Stage for var is set to implicit 0:Array.get
+- : ('a, 'b array -> int -> 'b) code = .<Array.get>.
+# .<List.nth>.;;
+X: Stage for var is set to implicit 0:List.nth
+- : ('a, 'b list -> int -> 'b) code = .<List.nth>.
+
+More CSP are carried as literals.
+
+When compiling code expressions, warnings should be disabled since
+they are not informative anyway. See runcode.ml, the function
+with_disabled_warnings.
+
+
+* Done in N100 (January 2013)
+
+** trx.ml is re-written, and so most of the following has been taken
+care of
+
+In [old] trx.ml, check to see if ident_can_be_quoted and path_to_lid
+can be merged to a single function, following the idea that any path
+made of global/persistent components can be safely converted to lident
+(the time stamps are all zero anyway). Any such path can be used to
+refer to a CSP by name, since that path persists and is stable. I
+guess it is also important that it is global: we can expect the same
+name available when we compile the code and when we invoke the
+type-checker again at run-time.
+
+In trx.ml, there are notes on CSP, in the comments before mkcsp. If
+CSP id is long id, (global id), use it as a constant and generate the
+corresponding global ref code. Zero-arity constants such as [] or
+None, when used as CSP, can be included by value, and show as such
+when we print out the code values. OCaml 3.11 adds annotations for
+identifiers (see typing/annot.mli and search for Annot in
+env.mli). Annot are used for the sake of .annot files. That data could
+be useful to identify CSP that refer to external or global
+identifiers.
+
+** Re-written trx.ml now does more efficient traversal, so most
+of the following has been taken care of
+
+It seems that there is a lot of room for improvement. For example,
+run compiles and type-checks the code expression from scratch.
+Mainly, Trx.structure pre-processes the whole program, each and every
+expression and definition -- even if an expression contains no
+staging forms. That pre-processing re-builds the whole parse tree,
+which is wasteful, and slows down compilation for large programs.
+We should hook escape and bracket processing to the type-checker -- to
+typecore.ml, and be done. We pay for staging only when needed.
+
+I have hooked Trx.trx_structure as a post-processor to
+Typemod.type_structure. Now, top-level drivers (toplevel/toploop.ml,
+driver/compile.ml) no longer have to be modified. The function
+Typemod.type_structure traverses the whole structure expression,
+invoking typecore.type_exp and other functions. But Trx.trx_structure
+does a very similar traversal! I have to think how to simplify
+unnecessary traversal and hook trx processing deeper, perhaps within
+typecore.type_exp and typecore.type_binding. These are the only cases
+that matter...
+
+** Better quotation (which results in better printing of CSP *)
+# let l x = .<x>.;;
+val l : 'a -> ('cl, 'a) code = <fun> (* Polymorphic! *)
+# l 1;;
+- : ('a, int) code = .<(* cross-stage persistent value (as id: x) *)>.
+# l 1.0;;
+- : ('a, float) code = .<1.>. (* Now it prints as a constant *)
+
+** Record with polymorphic fields in brackets: problem solved
+
+A new way of running the code and its problems. Actually, the
+problems are old -- the Trx module cannot handle polymorphic
+values. It erroneously fails to generalize type variables. Here is
+the illustration of the bug.
+
+# .< {Trx.cde = .<1>.} >.;;
+- : ('a, int Trx.cde) code = .<{Trx.cde = .<1>.}>.
+# .! .< {Trx.cde = .<1>.} >.;;
+# .! .< {Trx.cde = .<1>.} >.;;
+This expression [1 is highlighted]
+has type ('a, int) code but is here used with type
+ ('b, int) code
+
+Exception: Trx.TypeCheckingError.
+
+Since the new way of running relies on the polymorphic values, the
+problem becomes acute.
+Compare:
+# let a1 = .<fun x -> .! .<1>.>.;;
+val a1 : ('a, 'b -> int) code = .<fun x_2 -> .!.<1>.>.
+# let a2 = .! a1;;
+val a2 : 'a -> int = <fun>
+# a2 42;;
+- : int = 1
+
+# let b1 = .<fun x -> Runcode.run {Trx.cde = .<1>.}>.;;
+val b1 : ('a, 'b -> int) code =
+ .<fun x_3 ->
+ (((* cross-stage persistent value (as id: Runcode.run) *))
+ {Trx.cde = .<1>.})>.
+# let b11 = {Trx.cde = b1 };;
+val b11 : ('a -> int) Trx.cde =
+ .<fun x_3 ->
+ (((* cross-stage persistent value (as id: Runcode.run) *))
+ {Trx.cde = .<1>.})>.
+
+# Runcode.run b11;;
+Warning X: this argument will not be used by the function.
+This expression has type ('a, int) code but is here used with type
+ ('b, int) code
+
+Exception: Trx.TypeCheckingError.
+
+Runcode re-typechecks the expression -- and here where the error comes
+in.
+
+One workaround: when trx pre-processes the code first-time around,
+it should detect {Trx.cde = xxx} that appears within quotation, and
+replace it with something else (Parsetree.exp?). After all, the
+type-checking has already happened; when the generated code is run, no
+real check are needed; so we can use the untyped Parsetree at will.
+
+I believe the problem is in the clause `Pexp_record(lid_sexp_list,
+opt_sexp)' of the function type_exp of the file typecore.ml. In the
+conditional branch of (is_type_exp_second_time sexp) being true, we
+may be missing generalization (or forget to introduce fresh type
+variables).
diff -Naur ocaml-4.02.1/metalib/ORIGINAL-LICENSE-META ocaml-ber-n102/metalib/ORIGINAL-LICENSE-META
--- ocaml-4.02.1/metalib/ORIGINAL-LICENSE-META 1970-01-01 01:00:00.000000000 +0100
+++ ocaml-ber-n102/metalib/ORIGINAL-LICENSE-META 2015-01-10 16:27:06.936030975 +0000
@@ -0,0 +1,50 @@
+
+Copyright 2002-2006
+Walid Taha's research group at Rice University and collaborators
+All Rights Reserved
+
+MetaOCaml is licensed as a patch to the respective distribution of
+OCaml upon which it is based. Please see OCaml licence for status of
+a patch.
+
+Permission is hereby granted, free of charge, to any person obtaining
+a copy of this software and associated documentation files (the
+"Software"), to deal with the Software without restriction, including
+without limitation the rights to use, copy, modify, merge, publish,
+distribute, sublicense, and/or sell copies of the Software, and to
+permit persons to whom the Software is furnished to do so, subject to
+the following conditions:
+
+Redistributions of source code must retain the above copyright notice,
+this list of conditions and the following disclaimers.
+
+ - Redistributions in binary form must reproduce the above copyright
+ notice, this list of conditions and the following disclaimers in
+ the documentation and/or other materials provided with the
+ distribution.
+
+ - Neither the names of MetaOCaml, Concoqtion, Rice University, nor the
+ names of its contributors may be used to endorse or promote products
+ derived from this Software without specific prior written permission.
+
+ - Products derived from this software may not be called "MetaOCaml",
+ "MetaOCaml Concoqtion", "Concoqtion", or an extension of these names
+ without prior written permission from the RAP group.
+
+Commercial use is prohibited without prior written permission.
+
+Permissions must be granted by
+
+ Walid Taha (taha@rice.edu)
+ Department of Computer Science
+ Rice University, Houston, TX 77025.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+NONINFRINGEMENT. IN NO EVENT SHALL THE CONTRIBUTORS OR COPYRIGHT
+HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER
+IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR
+IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS WITH THE
+SOFTWARE.
+
diff -Naur ocaml-4.02.1/metalib/patches/patch ocaml-ber-n102/metalib/patches/patch
--- ocaml-4.02.1/metalib/patches/patch 1970-01-01 01:00:00.000000000 +0100
+++ ocaml-ber-n102/metalib/patches/patch 2015-01-10 16:27:06.936030975 +0000
@@ -0,0 +1,793 @@
+diff --git a/.depend b/.depend
+index 5d95a9b..63a137f 100644
+--- a/.depend
++++ b/.depend
+@@ -122,6 +122,9 @@ typing/printtyped.cmi : typing/typedtree.cmi
+ typing/stypes.cmi : typing/typedtree.cmi parsing/location.cmi \
+ typing/annot.cmi
+ typing/subst.cmi : typing/types.cmi typing/path.cmi typing/ident.cmi
++typing/trx.cmi : typing/types.cmi typing/typedtree.cmi parsing/parsetree.cmi \
++ parsing/longident.cmi parsing/location.cmi typing/env.cmi \
++ parsing/asttypes.cmi
+ typing/typeclass.cmi : typing/types.cmi typing/typedtree.cmi \
+ parsing/parsetree.cmi parsing/longident.cmi parsing/location.cmi \
+ typing/ident.cmi typing/env.cmi typing/ctype.cmi parsing/asttypes.cmi
+@@ -280,6 +283,18 @@ typing/subst.cmo : typing/types.cmi utils/tbl.cmi typing/path.cmi \
+ typing/subst.cmx : typing/types.cmx utils/tbl.cmx typing/path.cmx \
+ utils/misc.cmx parsing/location.cmx typing/ident.cmx utils/clflags.cmx \
+ typing/btype.cmx parsing/ast_mapper.cmx typing/subst.cmi
++typing/trx.cmo : utils/warnings.cmi typing/types.cmi typing/typedtree.cmi \
++ typing/printtyp.cmi typing/predef.cmi typing/path.cmi \
++ parsing/parsetree.cmi utils/misc.cmi parsing/longident.cmi \
++ parsing/location.cmi typing/ident.cmi typing/env.cmi typing/ctype.cmi \
++ typing/btype.cmi parsing/asttypes.cmi parsing/ast_helper.cmi \
++ typing/trx.cmi
++typing/trx.cmx : utils/warnings.cmx typing/types.cmx typing/typedtree.cmx \
++ typing/printtyp.cmx typing/predef.cmx typing/path.cmx \
++ parsing/parsetree.cmi utils/misc.cmx parsing/longident.cmx \
++ parsing/location.cmx typing/ident.cmx typing/env.cmx typing/ctype.cmx \
++ typing/btype.cmx parsing/asttypes.cmi parsing/ast_helper.cmx \
++ typing/trx.cmi
+ typing/typeclass.cmo : utils/warnings.cmi typing/typetexp.cmi \
+ typing/types.cmi typing/typedtree.cmi typing/typedecl.cmi \
+ typing/typecore.cmi parsing/syntaxerr.cmi typing/subst.cmi \
+@@ -299,23 +314,25 @@ typing/typeclass.cmx : utils/warnings.cmx typing/typetexp.cmx \
+ utils/clflags.cmx typing/btype.cmx parsing/asttypes.cmi \
+ parsing/ast_helper.cmx typing/typeclass.cmi
+ typing/typecore.cmo : utils/warnings.cmi typing/typetexp.cmi \
+- typing/types.cmi typing/typedtree.cmi parsing/syntaxerr.cmi \
+- typing/subst.cmi typing/stypes.cmi typing/printtyp.cmi \
+- typing/primitive.cmi typing/predef.cmi typing/path.cmi \
+- parsing/parsetree.cmi typing/parmatch.cmi typing/oprint.cmi \
+- utils/misc.cmi parsing/longident.cmi parsing/location.cmi \
+- typing/ident.cmi typing/env.cmi typing/ctype.cmi typing/cmt_format.cmi \
+- utils/clflags.cmi typing/btype.cmi parsing/asttypes.cmi \
+- parsing/ast_helper.cmi typing/annot.cmi typing/typecore.cmi
++ typing/types.cmi typing/typedtree.cmi typing/trx.cmi \
++ parsing/syntaxerr.cmi typing/subst.cmi typing/stypes.cmi \
++ typing/printtyp.cmi typing/primitive.cmi typing/predef.cmi \
++ typing/path.cmi parsing/parsetree.cmi typing/parmatch.cmi \
++ typing/oprint.cmi utils/misc.cmi parsing/longident.cmi \
++ parsing/location.cmi typing/ident.cmi typing/env.cmi typing/ctype.cmi \
++ typing/cmt_format.cmi utils/clflags.cmi typing/btype.cmi \
++ parsing/asttypes.cmi parsing/ast_helper.cmi typing/annot.cmi \
++ typing/typecore.cmi
+ typing/typecore.cmx : utils/warnings.cmx typing/typetexp.cmx \
+- typing/types.cmx typing/typedtree.cmx parsing/syntaxerr.cmx \
+- typing/subst.cmx typing/stypes.cmx typing/printtyp.cmx \
+- typing/primitive.cmx typing/predef.cmx typing/path.cmx \
+- parsing/parsetree.cmi typing/parmatch.cmx typing/oprint.cmx \
+- utils/misc.cmx parsing/longident.cmx parsing/location.cmx \
+- typing/ident.cmx typing/env.cmx typing/ctype.cmx typing/cmt_format.cmx \
+- utils/clflags.cmx typing/btype.cmx parsing/asttypes.cmi \
+- parsing/ast_helper.cmx typing/annot.cmi typing/typecore.cmi
++ typing/types.cmx typing/typedtree.cmx typing/trx.cmx \
++ parsing/syntaxerr.cmx typing/subst.cmx typing/stypes.cmx \
++ typing/printtyp.cmx typing/primitive.cmx typing/predef.cmx \
++ typing/path.cmx parsing/parsetree.cmi typing/parmatch.cmx \
++ typing/oprint.cmx utils/misc.cmx parsing/longident.cmx \
++ parsing/location.cmx typing/ident.cmx typing/env.cmx typing/ctype.cmx \
++ typing/cmt_format.cmx utils/clflags.cmx typing/btype.cmx \
++ parsing/asttypes.cmi parsing/ast_helper.cmx typing/annot.cmi \
++ typing/typecore.cmi
+ typing/typedecl.cmo : utils/warnings.cmi typing/typetexp.cmi \
+ typing/types.cmi typing/typedtree.cmi parsing/syntaxerr.cmi \
+ typing/subst.cmi typing/printtyp.cmi typing/primitive.cmi \
+diff --git a/Makefile b/Makefile
+index 6c0e7e6..287d183 100644
+--- a/Makefile
++++ b/Makefile
+@@ -20,6 +20,9 @@ CAMLOPT=boot/ocamlrun ./ocamlopt -nostdlib -I stdlib -I otherlibs/dynlink
+ COMPFLAGS=-strict-sequence -w +33..39+48 -warn-error A -bin-annot \
+ -safe-string $(INCLUDES)
+ LINKFLAGS=
++# For debugging
++# COMPFLAGS=-warn-error A -g $(INCLUDES) # NNN
++# LINKFLAGS=-g #NNN
+
+ CAMLYACC=boot/ocamlyacc
+ YACCFLAGS=-v
+@@ -49,6 +52,7 @@ PARSING=parsing/location.cmo parsing/longident.cmo \
+ parsing/pprintast.cmo \
+ parsing/ast_mapper.cmo
+
++# NNN (trx)
+ TYPING=typing/ident.cmo typing/path.cmo \
+ typing/primitive.cmo typing/types.cmo \
+ typing/btype.cmo typing/oprint.cmo \
+@@ -59,6 +63,7 @@ TYPING=typing/ident.cmo typing/path.cmo \
+ typing/mtype.cmo typing/envaux.cmo typing/includecore.cmo \
+ typing/typedtreeIter.cmo typing/typedtreeMap.cmo typing/cmt_format.cmo \
+ typing/includemod.cmo typing/typetexp.cmo typing/parmatch.cmo \
++ typing/trx.cmo \
+ typing/stypes.cmo typing/typecore.cmo \
+ typing/typedecl.cmo typing/typeclass.cmo \
+ typing/typemod.cmo
+@@ -130,6 +135,8 @@ all:
+ $(MAKE) otherlibraries $(OCAMLBUILDBYTE) $(WITH_DEBUGGER) \
+ $(WITH_OCAMLDOC)
+
++# NNN make all && (cd metalib && make clean all) && (make install; cd metalib && make install)
++
+ # Compile everything the first time
+ world:
+ $(MAKE) coldstart
+@@ -325,6 +332,13 @@ install:
+ $(INSTALL_COMPLIBDIR)
+ cp expunge $(INSTALL_LIBDIR)/expunge$(EXE)
+ cp toplevel/topdirs.cmi $(INSTALL_LIBDIR)
++# NNN typing/trx.ml needs its own interface (since it looks up identifiers
++# in itself)
++# Although typing/trx.cmi is already copied, see above, it is copied
++# into $((COMPLIBDIR). We need trx.cmi in the standard .cmi search path.
++ cp typing/trx.cmi $(INSTALL_LIBDIR)
++# BTW, trx.cmo is part of ocamlcommon.cma
++# NNN end
+ cd tools; $(MAKE) install
+ -cd man; $(MAKE) install
+ for i in $(OTHERLIBRARIES); do \
+@@ -744,7 +758,7 @@ html_doc: ocamldoc
+ partialclean::
+ cd ocamldoc && $(MAKE) clean
+
+-alldepend::
++alldepen1d::
+ cd ocamldoc && $(MAKE) depend
+
+ # The extra libraries
+diff --git a/parsing/lexer.mll b/parsing/lexer.mll
+index 237b447..c009d8b 100644
+--- a/parsing/lexer.mll
++++ b/parsing/lexer.mll
+@@ -270,6 +270,8 @@ let identchar_latin1 =
+ ['A'-'Z' 'a'-'z' '_' '\192'-'\214' '\216'-'\246' '\248'-'\255' '\'' '0'-'9']
+ let symbolchar =
+ ['!' '$' '%' '&' '*' '+' '-' '.' '/' ':' '<' '=' '>' '?' '@' '^' '|' '~']
++let symbolcharnodot = (* NNN *)
++ ['!' '$' '%' '&' '*' '+' '-' '/' ':' '<' '=' '>' '?' '@' '^' '|' '~'] (* NNN *)
+ let decimal_literal =
+ ['0'-'9'] ['0'-'9' '_']*
+ let hex_literal =
+@@ -302,6 +304,9 @@ rule token = parse
+ }
+ | blank +
+ { token lexbuf }
++ | ".<" { DOTLESS } (* NNN *)
++ | ">." { GREATERDOT } (* NNN *)
++ | ".~" { DOTTILDE } (* NNN *)
+ | "_"
+ { UNDERSCORE }
+ | "~"
+@@ -472,8 +477,10 @@ rule token = parse
+ { PREFIXOP(Lexing.lexeme lexbuf) }
+ | ['~' '?'] symbolchar +
+ { PREFIXOP(Lexing.lexeme lexbuf) }
+- | ['=' '<' '>' '|' '&' '$'] symbolchar *
++ | ['=' '<' '|' '&' '$'] symbolchar * (* NNN: ">." is not INFIXOP0 *)
+ { INFIXOP0(Lexing.lexeme lexbuf) }
++ | ['>'] symbolcharnodot symbolchar * (* NNN exclude ">." case *)
++ { INFIXOP0(Lexing.lexeme lexbuf) } (* NNN *)
+ | ['@' '^'] symbolchar *
+ { INFIXOP1(Lexing.lexeme lexbuf) }
+ | ['+' '-'] symbolchar *
+@@ -483,6 +490,8 @@ rule token = parse
+ | '%' { PERCENT }
+ | ['*' '/' '%'] symbolchar *
+ { INFIXOP3(Lexing.lexeme lexbuf) }
++ | "let" symbolchar* (* NNN *)
++ { LETOP(Lexing.lexeme lexbuf) } (* NNN *)
+ | eof { EOF }
+ | _
+ { raise (Error(Illegal_character (Lexing.lexeme_char lexbuf 0),
+diff --git a/parsing/parser.mly b/parsing/parser.mly
+index ba8e98e..43330f1 100644
+--- a/parsing/parser.mly
++++ b/parsing/parser.mly
+@@ -273,6 +273,21 @@ let wrap_type_annotation newtypes core_type body =
+ in
+ (exp, ghtyp(Ptyp_poly(newtypes,varify_constructors newtypes core_type)))
+
++ (* NNN: the whole definition *)
++let let_operator op bindings cont =
++ let pat, expr =
++ match bindings with
++ | [] -> assert false
++ | [x] -> (x.pvb_pat,x.pvb_expr)
++ | l ->
++ let pats, exprs =
++ List.fold_right
++ (fun {pvb_pat=p;pvb_expr=e} (ps,es) -> (p::ps,e::es)) l ([],[]) in
++ ghpat (Ppat_tuple pats), ghexp (Pexp_tuple exprs)
++ in
++ mkexp(Pexp_apply(op, [("", expr);
++ ("", ghexp(Pexp_fun("", None, pat, cont)))]))
++
+ let wrap_exp_attrs body (ext, attrs) =
+ (* todo: keep exact location for the entire attribute *)
+ let body = {body with pexp_attributes = attrs @ body.pexp_attributes} in
+@@ -293,6 +308,9 @@ let mkctf_attrs d attrs =
+
+ /* Tokens */
+
++%token DOTLESS /* NNN */
++%token GREATERDOT /* NNN */
++%token DOTTILDE /* NNN */
+ %token AMPERAMPER
+ %token AMPERSAND
+ %token AND
+@@ -358,6 +376,7 @@ let mkctf_attrs d attrs =
+ %token LESS
+ %token LESSMINUS
+ %token LET
++%token <string> LETOP /* NNN */
+ %token <string> LIDENT
+ %token LPAREN
+ %token LBRACKETAT
+@@ -441,6 +460,7 @@ The precedences must be listed from low to high.
+ %nonassoc below_SEMI
+ %nonassoc SEMI /* below EQUAL ({lbl=...; lbl=...}) */
+ %nonassoc LET /* above SEMI ( ...; let ... in ...) */
++%nonassoc LETOP /* NNN */
+ %nonassoc below_WITH
+ %nonassoc FUNCTION WITH /* below BAR (match ... with ...) */
+ %nonassoc AND /* above WITH (module rec A: SIG with ... and ...) */
+@@ -468,6 +488,7 @@ The precedences must be listed from low to high.
+ %nonassoc prec_unary_minus prec_unary_plus /* unary - */
+ %nonassoc prec_constant_constructor /* cf. simple_expr (C versus C x) */
+ %nonassoc prec_constr_appl /* above AS BAR COLONCOLON COMMA */
++%left prec_escape /* NNN */
+ %nonassoc below_SHARP
+ %nonassoc SHARP /* simple_expr/toplevel_directive */
+ %nonassoc below_DOT
+@@ -1084,6 +1105,8 @@ expr:
+ { mkexp(Pexp_apply($1, List.rev $2)) }
+ | LET ext_attributes rec_flag let_bindings_no_attrs IN seq_expr
+ { mkexp_attrs (Pexp_let($3, List.rev $4, $6)) $2 }
++ | let_operator ext_attributes let_bindings IN seq_expr /* NNN */
++ { wrap_exp_attrs (let_operator $1 $3 $5) $2 } /* NNN */
+ | LET MODULE ext_attributes UIDENT module_binding_body IN seq_expr
+ { mkexp_attrs (Pexp_letmodule(mkrhs $4 4, $5, $7)) $3 }
+ | LET OPEN override_flag ext_attributes mod_longident IN seq_expr
+@@ -1200,6 +1223,12 @@ simple_expr:
+ { reloc_exp $2 }
+ | LPAREN seq_expr error
+ { unclosed "(" 1 ")" 3 }
++ | DOTLESS expr GREATERDOT /* NNN */
++ { wrap_exp_attrs $2
++ (None,[ghloc "metaocaml.bracket",PStr []]) } /* NNN */
++ | DOTTILDE simple_expr %prec prec_escape /* NNN */
++ { wrap_exp_attrs $2
++ (None,[ghloc "metaocaml.escape",PStr []]) } /* NNN */
+ | BEGIN ext_attributes seq_expr END
+ { wrap_exp_attrs (reloc_exp $3) $2 (* check location *) }
+ | BEGIN ext_attributes END
+@@ -1961,6 +1990,7 @@ operator:
+ | INFIXOP2 { $1 }
+ | INFIXOP3 { $1 }
+ | INFIXOP4 { $1 }
++ | LETOP { $1 } /* NNN */
+ | BANG { "!" }
+ | PLUS { "+" }
+ | PLUSDOT { "+." }
+@@ -1978,6 +2008,16 @@ operator:
+ | PLUSEQ { "+=" }
+ | PERCENT { "%" }
+ ;
++ /* NNN: the whole definition */
++let_operator:
++ LETOP { mkexp (Pexp_ident(
++ mkloc (Lident $1)
++ (symbol_rloc ()))) }
++ | mod_longident DOT LETOP { mkexp (Pexp_ident(
++ mkloc (Ldot($1,$3))
++ (symbol_rloc ()))) }
++;
++
+ constr_ident:
+ UIDENT { $1 }
+ /* | LBRACKET RBRACKET { "[]" } */
+diff --git a/parsing/pprintast.ml b/parsing/pprintast.ml
+index 7dea70c..91ddb5e 100644
+--- a/parsing/pprintast.ml
++++ b/parsing/pprintast.ml
+@@ -47,6 +47,8 @@ let fixity_of_string = function
+
+ let view_fixity_of_exp = function
+ | {pexp_desc = Pexp_ident {txt=Lident l;_};_} -> fixity_of_string l
++ | {pexp_desc = Pexp_ident {txt=Ldot (Lident "Pervasives",l);_};_} -> (*NNN*)
++ fixity_of_string l (*NNN*)
+ | _ -> `Normal ;;
+
+ let is_infix = function | `Infix _ -> true | _ -> false
+@@ -512,11 +514,44 @@ class printer ()= object(self:'self)
+ end
+ | _ -> false
+ method expression f x =
+- if x.pexp_attributes <> [] then begin
++ (* NNN begin *)
++ (* Keep in mind that there may be several metaocaml
++ attributes, and the order matters *)
++ (* Here we assume that all metaocaml attributes are at the front,
++ which is how they are generated.
++ *)
++ match x.pexp_attributes with
++ | ({txt="metaocaml.bracket"},_) :: t ->
++ pp f "@[<hov2>.<@ %a @ >.@]" self#expression {x with pexp_attributes=t}
++ | ({txt="metaocaml.escape"},_) :: t ->
++ begin
++ match x.pexp_desc with
++ | Pexp_ident li when t = [] -> pp f ".~%a" self#longident_loc li
++ | _ -> pp f ".~%a" (self#paren true self#expression)
++ {x with pexp_attributes=t}
++ end
++ | [({txt = "metaocaml.csp"},PStr [{pstr_desc =
++ Pstr_eval ({pexp_desc=Pexp_ident li},_)}])] ->
++ begin
++ (* This CSP is easy to print, so we print it *)
++ match x.pexp_desc with
++ | Pexp_apply (_,[("",{pexp_desc=Pexp_constant (Const_int _)})])
++ ->
++ pp f "(* CSP %a *) %a"
++ self#longident_loc li
++ self#expression {x with pexp_attributes=[]}
++ | _ ->
++ pp f "(* CSP %a *)"
++ self#longident_loc li
++ end
++ (* if x.pexp_attributes <> [] then begin *)
++ | _::_ ->
+ pp f "((%a)%a)" self#expression {x with pexp_attributes=[]}
+ self#attributes x.pexp_attributes
+- end
+- else match x.pexp_desc with
++ (* end *)
++ | _ -> begin match x.pexp_desc with
++ (* else match x.pexp_desc with *)
++ (* NNN end *)
+ | Pexp_function _ | Pexp_fun _ | Pexp_match _ | Pexp_try _ | Pexp_sequence _
+ when pipe || semi ->
+ self#paren true self#reset#expression f x
+@@ -620,6 +655,7 @@ class printer ()= object(self:'self)
+ pp f "@[<2>`%s@;%a@]" l self#simple_expr eo
+ | Pexp_extension e -> self#extension f e
+ | _ -> self#expression1 f x
++ end (* NNN *)
+ method expression1 f x =
+ if x.pexp_attributes <> [] then self#expression f x
+ else match x.pexp_desc with
+diff --git a/typing/predef.ml b/typing/predef.ml
+index e9b9f7e..9a08a86 100644
+--- a/typing/predef.ml
++++ b/typing/predef.ml
+@@ -120,6 +120,17 @@ and ident_nil = ident_create "[]"
+ and ident_cons = ident_create "::"
+ and ident_none = ident_create "None"
+ and ident_some = ident_create "Some"
++
++(* NNN ident_create "code" must be placed at the end of all other
++ ident creation expressions, to make sure that creating ident_code
++ does not shift the timestamps of other standard idents like
++ Eof, etc. Otherwise, binary compatibility with OCaml breaks,
++ and we have to do the expensive bootstrapping.
++*)
++let ident_code = ident_create "code" (* NNN *)
++let path_code = Pident ident_code (* NNN *)
++let type_code t = newgenty (Tconstr(path_code, [t], ref Mnil)) (* NNN *)
++
+ let common_initial_env add_type add_extension empty_env =
+ let decl_bool =
+ {decl_abstr with
+@@ -157,6 +168,13 @@ let common_initial_env add_type add_extension empty_env =
+ type_params = [tvar];
+ type_arity = 1;
+ type_variance = [Variance.covariant]}
++ (* NNN added decl_code *)
++ and decl_code =
++ let tvar = newgenvar() in
++ {decl_abstr with
++ type_params = [tvar];
++ type_arity = 1;
++ type_variance = [Variance.covariant]}
+ in
+
+ let add_extension id l =
+@@ -184,6 +202,7 @@ let common_initial_env add_type add_extension empty_env =
+ [newgenty (Ttuple[type_string; type_int; type_int])] (
+ add_extension ident_undefined_recursive_module
+ [newgenty (Ttuple[type_string; type_int; type_int])] (
++ add_type ident_code decl_code ( (* NNN *)
+ add_type ident_int64 decl_abstr (
+ add_type ident_int32 decl_abstr (
+ add_type ident_nativeint decl_abstr (
+@@ -198,7 +217,8 @@ let common_initial_env add_type add_extension empty_env =
+ add_type ident_string decl_abstr (
+ add_type ident_char decl_abstr (
+ add_type ident_int decl_abstr (
+- empty_env))))))))))))))))))))))))))
++ empty_env)))))))))))))))))))))))))) ) (* NNN extra parenthesis *)
++
+
+ let build_initial_env add_type add_exception empty_env =
+ let common = common_initial_env add_type add_exception empty_env in
+diff --git a/typing/predef.mli b/typing/predef.mli
+index 9723671..29f79d6 100644
+--- a/typing/predef.mli
++++ b/typing/predef.mli
+@@ -29,6 +29,7 @@ val type_nativeint: type_expr
+ val type_int32: type_expr
+ val type_int64: type_expr
+ val type_lazy_t: type_expr -> type_expr
++val type_code: type_expr -> type_expr (* NNN *)
+
+ val path_int: Path.t
+ val path_char: Path.t
+@@ -45,6 +46,7 @@ val path_nativeint: Path.t
+ val path_int32: Path.t
+ val path_int64: Path.t
+ val path_lazy_t: Path.t
++val path_code: Path.t (* NNN *)
+
+ val path_match_failure: Path.t
+ val path_assert_failure : Path.t
+diff --git a/typing/typecore.ml b/typing/typecore.ml
+index b173d99..bbbbeef 100644
+--- a/typing/typecore.ml
++++ b/typing/typecore.ml
+@@ -93,6 +93,91 @@ let type_object =
+ Env.t -> Location.t -> Parsetree.class_structure ->
+ Typedtree.class_structure * Types.class_signature * string list)
+
++(* NNN: begin
++ The current stage level.
++ Type-checking the body of a bracket increases the level,
++ type-checking of an escape decreases.
++ Be sure to reset upon any exception;
++ alternatively; reset when beginning a new type-level
++ expression or binding
++ (whenever you do Typetexp.reset_type_variables();)
++
++ Check all instances of Env.add_value and make sure that
++ we record the stage of every identifier that is added to the
++ value env (unless the stage is 0).
++also check all val_attributes and Val_reg
++*)
++let global_stage : Trx.stage ref = ref 0
++
++(* Obsolete; kept for reference
++
++ The list of active classifiers. The length of the list
++ is the level of an expression.
++ Type-checking the body of a bracket adds a type variable
++ to the list; type-checking of an escape removes the
++ top-most classifier.
++ Be sure to reset this list upon any exception;
++ alternatively; reset the list when beginning a new type-level
++ expression or binding
++ (whenever you do Typetexp.reset_type_variables();)
++
++let global_stage : Env.stage ref = ref []
++
++ Unify classifier lists, *right-to-left*
++ See the bug Tue Jan 20 12:18:00 GMTST 2004 in XXCC-BUG-OPEN-FIXED
++ why we need this order.
++ The current classifier is left-most, and the lists don't have
++ to have the same length.
++ Example:
++ .<fun x -> .< x >. >.
++ When type-checking the innermost bracket, the global_stage
++ will contain ['b,'a] and the level of x will be ['a]
++ The unification will succeed, without changing anything, as expected.
++
++let unify_stage env tl1 tl2 =
++ let rec loop = function
++ | (t1::tl1,t2::tl2) -> unify env t1 t2; loop (tl1,tl2)
++ | _ -> ()
++ in loop (List.rev tl1, List.rev tl2)
++*)
++
++(* This function does not take the env argument. Normally env affects
++ the printing of paths (search for raise_wrong_stage_error
++ in this file and printtyp.ml).
++ The particular error message we emit here does not use paths.
++*)
++let raise_wrong_stage_error loc n m =
++ raise @@
++ Error_forward(Location.errorf ~loc
++ "Wrong level: variable bound at level %d and used at level %d" n m)
++
++let raise_unsupported loc txt =
++ raise @@
++ Error_forward(Location.errorf ~loc
++ "Not supported within brackets: %s" txt)
++
++let with_stage_up body =
++ let old_stage = !global_stage in
++ let () = incr global_stage in
++ try
++ let r = body () in
++ global_stage := old_stage; r
++ with e ->
++ global_stage := old_stage; raise e
++
++let with_stage_down loc env body =
++ let old_stage = !global_stage in
++ if !global_stage = 0 then
++ raise @@ Error_forward(Location.errorf ~loc
++ "Wrong level: escape at level 0");
++ decr global_stage;
++ try
++ let r = body () in
++ global_stage := old_stage; r
++ with e ->
++ global_stage := old_stage; raise e
++(* NNN end *)
++
+ (*
+ Saving and outputting type information.
+ We keep these function names short, because they have to be
+@@ -1258,7 +1343,7 @@ let add_pattern_variables ?check ?check_as env =
+ let check = if as_var then check_as else check in
+ Env.add_value ?check id
+ {val_type = ty; val_kind = Val_reg; Types.val_loc = loc;
+- val_attributes = [];
++ val_attributes = [Trx.attr_level !global_stage] (* NNN *)
+ } env
+ )
+ pv env,
+@@ -1301,7 +1386,8 @@ let type_class_arg_pattern cl_num val_env met_env l spat =
+ ((id', name, id, ty)::pv,
+ Env.add_value id' {val_type = ty;
+ val_kind = Val_ivar (Immutable, cl_num);
+- val_attributes = [];
++ val_attributes =
++ [Trx.attr_level !global_stage]; (* NNN *)
+ Types.val_loc = loc;
+ } ~check
+ env))
+@@ -1325,6 +1411,10 @@ let type_self_pattern cl_num privty val_env met_env par_env spat =
+ let pv = !pattern_variables in
+ pattern_variables := [];
+ let (val_env, met_env, par_env) =
++ (* NNN we don't record stage for
++ Env.add_value below
++ since we don't handle classes within brackets.
++ *)
+ List.fold_right
+ (fun (id, ty, name, loc, as_var) (val_env, met_env, par_env) ->
+ (Env.add_value id {val_type = ty;
+@@ -1377,6 +1467,7 @@ let rec final_subexpression sexp =
+ (* Generalization criterion for expressions *)
+
+ let rec is_nonexpansive exp =
++ List.memq Trx.attr_nonexpansive exp.exp_attributes || (* NNN *)
+ match exp.exp_desc with
+ Texp_ident(_,_,_) -> true
+ | Texp_constant _ -> true
+@@ -1491,7 +1582,14 @@ let rec approx_type env sty =
+ approx_type env sty
+ | _ -> newvar ()
+
+-let rec type_approx env sexp =
++let rec type_approx env sexp = (* NNN the whole function *)
++ let open Trx in
++ match what_stage_attr sexp.pexp_attributes with
++ | Stage0 -> type_approx_orig env sexp
++ (* instance env @@ Predef.type_code @@ type_approx_orig env sexp *)
++ | _ -> newvar ()
++and
++ type_approx_orig env sexp = (* NNN end *)
+ match sexp.pexp_desc with
+ Pexp_let (_, _, e) -> type_approx env e
+ | Pexp_fun (p, _, _, e) when is_optional p ->
+@@ -1702,6 +1800,11 @@ let duplicate_ident_types loc caselist env =
+ I don't think this is what we want *)
+ let (path, desc) = Env.lookup_value (Longident.Lident s) env in
+ match path with
++ (* NNN The code below uses the existing desc (value-descriptor)
++ as the template and simply changes val_type.
++ The attributes, specifically staging level attribute,
++ are preserved then.
++ *)
+ Path.Pident id ->
+ let desc = {desc with val_type = correct_levels desc.val_type} in
+ Env.add_value id desc env
+@@ -1736,8 +1839,66 @@ and type_expect ?in_function env sexp ty_expected =
+ (Cmt_format.Partial_expression exp :: previous_saved_types);
+ exp
+
++(* NNN This whole function type_expect_ *)
++(* Type checking staging constructs *)
++(* If we are type-checking bracket at level 0, don't build the
++ bracket Texp node. Rather, invoke trx_bracket to translate
++ the bracket body and convert it to the c ode generator.
++*)
+ and type_expect_ ?in_function env sexp ty_expected =
+ let loc = sexp.pexp_loc in
++ let open Trx in
++ (* Keep in mind that there may be several metaocaml attributes,
++ and their order matters.
++ *)
++ match what_stage_attr sexp.pexp_attributes with
++ | Stage0 -> type_expect_orig ?in_function env sexp ty_expected
++ | Bracket(battr,attrs) ->
++ (* Typechecking bracket *)
++ (* follow Pexp_array or Pexp_lazy as a template *)
++ (* Expected type: ty code where ty is the type
++ of the expression within brackets.
++ *)
++ let ty = newgenvar() in (* expected type for the bracketed sexp *)
++ let to_unify = Predef.type_code ty in
++ unify_exp_types loc env to_unify ty_expected;
++ let exp =
++ with_stage_up (fun () ->
++ (* drop bracket attr *)
++ let sexp = {sexp with pexp_attributes = attrs} in
++ type_expect env sexp ty) in
++ re @@
++ if !global_stage = 0 then
++ (* Check if the expression non-expansive before the translation *)
++ let nonexp = is_nonexpansive exp in
++ let exp = trx_bracket 1 exp in
++ {exp with exp_type = instance env ty_expected;
++ exp_attributes =
++ if nonexp then attr_nonexpansive :: exp.exp_attributes
++ else exp.exp_attributes}
++ else
++ texp_braesc battr exp env (instance env ty_expected)
++
++ (* NNN: Typechecking escapes *)
++ (* If ~e is expected to have the type ty then
++ e is expected to have the type ty code
++ *)
++ | Escape(battr,attrs) ->
++ with_stage_down loc env (fun () ->
++ let sexp_ty_expected = Predef.type_code ty_expected in
++ let sexp = {sexp with pexp_attributes = attrs} in (* drop bracket attr *)
++ let exp = type_expect env sexp sexp_ty_expected in
++ re @@
++ texp_braesc battr exp env (instance env ty_expected))
++
++ (* There is nothing special in type-checking CSPs.
++ After lifting, a CSP value becomes an ordinaru expression.
++ *)
++ | _ -> type_expect_orig ?in_function env sexp ty_expected
++ (* NNN end *)
++
++and type_expect_orig ?in_function env sexp ty_expected = (* NNN *)
++ let loc = sexp.pexp_loc in
+ (* Record the expression type before unifying it with the expected type *)
+ let rue exp =
+ unify_exp env (re exp) (instance env ty_expected);
+@@ -1756,6 +1917,7 @@ and type_expect_ ?in_function env sexp ty_expected =
+ let name = Path.name ~paren:Oprint.parenthesized_ident path in
+ Stypes.record (Stypes.An_ident (loc, name, annot))
+ end;
++ let stage = Trx.get_level desc.val_attributes in (* NNN *)
+ rue {
+ exp_desc =
+ begin match desc.val_kind with
+@@ -1779,9 +1941,13 @@ and type_expect_ ?in_function env sexp ty_expected =
+ Env.add_required_global (Path.head p);
+ Texp_ident(path, lid, desc)*)
+ | _ ->
++ if stage > !global_stage then (* NNN *)
++ raise_wrong_stage_error loc stage !global_stage (* NNN *)
++ else (* NNN *)
+ Texp_ident(path, lid, desc)
+ end;
+ exp_loc = loc; exp_extra = [];
++(* NNN: Instantiates type scheme to a type *)
+ exp_type = instance env desc.val_type;
+ exp_attributes = sexp.pexp_attributes;
+ exp_env = env }
+@@ -1875,9 +2041,9 @@ and type_expect_ ?in_function env sexp ty_expected =
+ in
+ type_expect ?in_function env sfun ty_expected
+ (* TODO: keep attributes, call type_function directly *)
+- | Pexp_fun (l, None, spat, sexp) ->
++ | Pexp_fun (l, None, spat, sexp_body) -> (* NNN fixing the bug: sexp_body *)
+ type_function ?in_function loc sexp.pexp_attributes env ty_expected
+- l [{pc_lhs=spat; pc_guard=None; pc_rhs=sexp}]
++ l [{pc_lhs=spat; pc_guard=None; pc_rhs=sexp_body}]
+ | Pexp_function caselist ->
+ type_function ?in_function
+ loc sexp.pexp_attributes env ty_expected "" caselist
+@@ -2195,7 +2361,8 @@ and type_expect_ ?in_function env sexp ty_expected =
+ | Ppat_any -> Ident.create "_for", env
+ | Ppat_var {txt} ->
+ Env.enter_value txt {val_type = instance_def Predef.type_int;
+- val_attributes = [];
++ val_attributes = (* NNN *)
++ [Trx.attr_level !global_stage];
+ val_kind = Val_reg; Types.val_loc = loc; } env
+ ~check:(fun s -> Warnings.Unused_for_index s)
+ | _ ->
+@@ -2357,7 +2524,8 @@ and type_expect_ ?in_function env sexp ty_expected =
+ Texp_ident(Path.Pident method_id, lid,
+ {val_type = method_type;
+ val_kind = Val_reg;
+- val_attributes = [];
++ val_attributes = (* NNN *)
++ [Trx.attr_level !global_stage];
+ Types.val_loc = Location.none});
+ exp_loc = loc; exp_extra = [];
+ exp_type = method_type;
+@@ -2428,6 +2596,8 @@ and type_expect_ ?in_function env sexp ty_expected =
+ exp_env = env }
+ end
+ | Pexp_setinstvar (lab, snewval) ->
++ if !global_stage != 0 then (* NNN *)
++ raise_unsupported loc "setinstvar"; (* NNN *)
+ begin try
+ let (path, desc) = Env.lookup_value (Longident.Lident lab.txt) env in
+ match desc.val_kind with
+@@ -2452,6 +2622,8 @@ and type_expect_ ?in_function env sexp ty_expected =
+ raise(Error(loc, env, Unbound_instance_variable lab.txt))
+ end
+ | Pexp_override lst ->
++ if !global_stage != 0 then (* NNN *)
++ raise_unsupported loc "override"; (* NNN *)
+ let _ =
+ List.fold_right
+ (fun (lab, _) l ->
+@@ -2490,6 +2662,8 @@ and type_expect_ ?in_function env sexp ty_expected =
+ assert false
+ end
+ | Pexp_letmodule(name, smodl, sbody) ->
++ if !global_stage != 0 then (* NNN *)
++ raise_unsupported loc "letmodule"; (* NNN *)
+ let ty = newvar() in
+ (* remember original level *)
+ begin_def ();
+@@ -3094,7 +3268,7 @@ and type_argument env sarg ty_expected' ty_expected =
+ exp_desc =
+ Texp_ident(Path.Pident id, mknoloc (Longident.Lident name),
+ {val_type = ty; val_kind = Val_reg;
+- val_attributes = [];
++ val_attributes = [Trx.attr_level !global_stage]; (* NNN *)
+ Types.val_loc = Location.none})}
+ in
+ let eta_pat, eta_var = var_pair "eta" ty_arg in
+@@ -3722,6 +3896,7 @@ and type_let ?(check = fun s -> Warnings.Unused_var s)
+
+ let type_binding env rec_flag spat_sexp_list scope =
+ Typetexp.reset_type_variables();
++ global_stage := 0; (* NNN *)
+ let (pat_exp_list, new_env, unpacks) =
+ type_let
+ ~check:(fun s -> Warnings.Unused_value_declaration s)
+@@ -3739,17 +3914,34 @@ let type_let env rec_flag spat_sexp_list scope =
+
+ let type_expression env sexp =
+ Typetexp.reset_type_variables();
++ global_stage := 0; (* NNN *)
+ begin_def();
+ let exp = type_exp env sexp in
+ end_def();
+ if is_nonexpansive exp then generalize exp.exp_type
+ else generalize_expansive env exp.exp_type;
++ (* NNN The original code
+ match sexp.pexp_desc with
+ Pexp_ident lid ->
+ (* Special case for keeping type variables when looking-up a variable *)
+ let (path, desc) = Env.lookup_value lid.txt env in
+ {exp with exp_type = desc.val_type}
+ | _ -> exp
++ We have to modify it since <x> is also Pexp_ident, with the additional
++ attribute though. So, either we have to check for metaocaml.bracket
++ attribute, or, better, check exp. After type-checking, <x> is no longer
++ Pexp_ident. For ordinary identifiers though, Pexp_ident li maps to
++ Texp_ident (..,li,..) -- with the exception of instance vars, which
++ don't matter at the ttoplevel anyway.
++*)
++ (* NNN new code *)
++ match exp.exp_desc with
++ Texp_ident (_,lid,_) ->
++ (* Special case for keeping type variables when looking-up a variable *)
++ let (path, desc) = Env.lookup_value lid.txt env in
++ {exp with exp_type = desc.val_type}
++ | _ -> exp
++ (* NNN end *)
+
+ (* Error report *)
+
diff -Naur ocaml-4.02.1/metalib/print_code.ml ocaml-ber-n102/metalib/print_code.ml
--- ocaml-4.02.1/metalib/print_code.ml 1970-01-01 01:00:00.000000000 +0100
+++ ocaml-ber-n102/metalib/print_code.ml 2015-01-10 16:27:06.936030975 +0000
@@ -0,0 +1,43 @@
+(* Printing code expressions *)
+
+(* The original code was authored by Ed Pizzi
+ and simplified by Jacques Carette.
+ It is latter borrowed into the main OCaml tree,
+ as parsing/pprintast.ml.
+ It was extensively rewritten by Hongbo Zhang: University of Pennsylvania
+ and modified by Thomas Gazagnaire (OCamlPro) and
+ Fabrice Le Fessant (INRIA Saclay).
+
+ We now rely on the OCaml's code.
+*)
+
+open Format
+open Runcode
+
+
+(* print code as a parse tree. Useful for debugging *)
+let print_code_as_ast cde =
+ let cde = (cde : Trx.closed_code_repr :> Parsetree.expression) in
+ Printast.implementation Format.std_formatter
+ [Ast_helper.Str.eval cde]
+
+let format_code : Format.formatter -> 'a closed_code -> unit = fun ppf cde ->
+ let cde = (cde : Trx.closed_code_repr :> Parsetree.expression) in
+ Pprintast.expression ppf cde
+
+(* These functions are suitable for installing as printers
+ at the toplevel, using top-level directive install printer.
+ Don't rename these functions or change their types.
+ See bertop.ml, which refers to these functions by their external
+ symbolic name.
+*)
+
+let print_closed_code : Format.formatter -> 'a closed_code -> unit =
+ fun ppf cde ->
+ Format.fprintf ppf ".<@,%a>.@ " format_code cde
+
+let print_code ppf (cde : 'a code) =
+ let (cde, check) = close_code_delay_check cde in
+ print_closed_code ppf cde;
+ try check ()
+ with e -> fprintf ppf "\n%s" (Printexc.to_string e)
diff -Naur ocaml-4.02.1/metalib/print_code.mli ocaml-ber-n102/metalib/print_code.mli
--- ocaml-4.02.1/metalib/print_code.mli 1970-01-01 01:00:00.000000000 +0100
+++ ocaml-ber-n102/metalib/print_code.mli 2015-01-10 16:27:06.936030975 +0000
@@ -0,0 +1,18 @@
+(* Printing code expressions *)
+
+open Runcode
+
+(* Print code values, useful as formatter.
+ The code is printed with outer brackets
+*)
+val print_code : Format.formatter -> 'a code -> unit
+val print_closed_code : Format.formatter -> 'a closed_code -> unit
+
+(* Like print_closed_code, but omit the outer brackets.
+ This function is useful when saving the generated code into a file,
+ to compile later.
+*)
+val format_code : Format.formatter -> 'a closed_code -> unit
+
+(* print code as a parse tree. Useful for debugging *)
+val print_code_as_ast : 'a closed_code -> unit
diff -Naur ocaml-4.02.1/metalib/Problems.txt ocaml-ber-n102/metalib/Problems.txt
--- ocaml-4.02.1/metalib/Problems.txt 1970-01-01 01:00:00.000000000 +0100
+++ ocaml-ber-n102/metalib/Problems.txt 2015-01-10 16:27:06.936030975 +0000
@@ -0,0 +1,208 @@
+ Open and closed problems
+
+June 11, 2010.
+
+While designing a counter-example, I was too
+successful. The counter-example worked, also for OCaml
+
+let lift x = .<x>.;;
+let fff =
+ .<let foo = fun x -> let t = .~(lift (ref [])) in
+ (match !t with [] -> t := [x]; x | [y] -> t := [x]; y) in
+ (foo ("xxx"), foo(true), foo([1,2]))>.;;
+
+So, the future-stage lambda should not be considered unexpansive by
+default. We should check the body for escapes. In principle,
+we should also check for CSP -- however MetaOCaml, unlike the
+calculus of PEPM03 paper, permits CSP of only values rather than
+expressions. And we know that we can't have a polymorphic reference
+cell bound to an identifier or as a constant.
+So, we should declare expansive those future-stage lambda whose
+bodies contain expansive escapes (that is, escapes that are not
+manifest code constants such as <0>). We should be careful of multiple-levels
+though; the problem above occurs because ``polymorphic'' reference cell can
+be a value (once created), and can be lifted to code. So, we should
+conservatively regard as potentially expansive a future-stage lambda
+that has expansive escapes to any level.
+
+
+
+May 5, 2010
+Loading test/test21.ml in top-level works fine. However, compiling
+that file gives
+ Fatal error: exception Invalid_argument("output_value: functional value")
+
+If we pass the flags -drawlambda -dinstr to the compiler, we observe
+that the constants "" and Pervasive.^ are accompanied with
+environments (which are probably useless in that case anyway).
+If the code file has nested modules, it seems the environemnt has
+functional values. Therefore, attempting to serialize such an
+environment fails.
+
+The permanent solution requires re-thinking of building parsetree at run-time
+(see quote_constant in trx.ml)
+We shouldn't probably attach environemnt to contants. Also, we should
+get rid of location information, which is not needed and can be
+confusing.
+
+
+It turns out that the environment indeed contains functional values.
+The patch from Fabrice Le Fessant (who faced a similar problem in
+JoCaml) helped.
+
+
+
+-- Older
+
+
+
+(* CSP issues *)
+let f = fun x -> .<x>.;;
+let a = .<fun y -> .~(f .<y>.)>.;;
+let b = .! a;;
+let c = b 56;;
+let d = .! c;;
+
+let f = fun x -> .<x>.;;
+let a = .<fun y -> .~(f .<.<y>.>.)>.;;
+let b = .! a;;
+let c = b 56;;
+let d = .! c;;
+
+let f = fun x -> .<x>.;;
+let a = .<fun y -> f y>.;;
+let f2 = .! a;;
+let a2 = .<fun y -> .~(f2 .<.<y>.>.)>.;;
+let b = .! a2;;
+let c = b 56;;
+let d = .! c;;
+
+
+(* Type synonyms/aliasing bug: *)
+-- Description: Pattern matching against a value whose type is a type
+synonym, while using the pattern alias (as s) results in a
+type-checking error when applying .! to a piece of code.
+
+-- The smallest example of this bug is:
+type vect = int * int;;
+type state = State of vect;;
+let f state = .<let (State d) as s = .~state in
+ let (u,v) = d in 34>.;;
+let c = f .<State (2,3)>. in .! c;;
+
+-- error: "This expression has type vect but is here used with type 'a * 'b"
+
+-- The piece of code where this exception is raised is the call to
+(type_expect) in the function type_let in typecore.ml.
+
+-- Suspected reasons: The type synonym 'vect' is not unified with 'a *
+'b, which it should be. The problem seems the way that we handle
+environments. When type-checking run, the (initial) environment in
+which it is type-checked does not seem to contain a binding for the
+type vect.
+
+-- General note: This problem seems to be an artifact of how we
+ implement environments. Perhaps we need to deal with these things
+ more systematically.
+
+
+Oct 3, 2006
+ printing of `record with expressions'
+ type recd = {f1 : int; f2 : string};;
+
+ let foo = .<let x = {f1=1; f2="a"} in
+ let y = {x with f1 = 2} in
+ y>.
+ ;;
+
+ produces the output
+ val foo : ('a, recd) code =
+ .<let x_3 = {f1 = 1; f2 = "a"} in let y_4 = {f1 = 2} (x_3) in y_4>.
+
+ The expression "{f1 = 2} (x_3)" obviously can't be right: a record is
+ not a function and can't be applied.
+
+ That is merely a printing issue:
+ .! foo;;
+ - : recd = {f1 = 2; f2 = "a"}
+
+ which is correct.
+
+
+Tue Jan 18 14:08:52 GMTST 2005
+ BUG: type aliases are not handled correctly in code, example:
+ # type a = int;;
+ # let f (x:a) = 1;;
+ # .! .<f 1>.;;
+ This expression has type int but is here used with type a
+ PROBLEM: the type of csp constants cannot resolve type aliases
+ FIX: when typing Pexp_cspval return a fresh variable so it will type
+ check in any situation
+
+Tue Jan 11 11:19:23 GMTST 2005
+ BUG: records, constructors etc are typed once and their type is reused, same
+ bug as on Jan 10 2005.
+ FIXED: when typing e.g. a record field access (Pexp_field) the stored type
+ is still used to get the label description (used by the compiler to compute
+ the offset for field access), but the toplevel type is not reused and a
+ fresh type variable is returned instead. In this way we avoid that several
+ runs of code coming from the same field access have their types unified.
+
+Mon Jan 10 18:51:21 GMTST 2005
+ BUG: csp constants in Pervasives (and similar) are type checked only once for
+ a given occurrence.
+ # let f x = .< ref .~ x>.
+ in (.! (f .<3>.), .! (f .<1.3>.));;
+ This expression has type int but is here used with type float
+ Exception: Trx.TypeCheckingError.
+ PROBLEM: "ref" is typechecked only once when f is declared, and the resulting
+ type is used twice in the second line
+ FIXED: typing/typecore.ml now re-createx the untyped parsetree for the
+ Pervasive identifier and type-checks it again.
+
+Tue Jan 20 12:18:00 GMTST 2004
+ BUG: typechecker broken for csp ids, e.g. we get the wrong type
+ We get the incorrect typing (inner and outer code forced to be both 'a)
+ # .<fun x -> .<x>.>.;;
+ - : ('a, 'b -> ('a, 'b) code) code = .<fun (x_2) -> .<(x_2)>.>.
+ PROBLEM: typechecker unifies the current level with the id's level left-to-right
+ but the latest classifier is the leftmost.
+ FIXED: levels are now unified right-to-left, and get correct type:
+ # .<fun x -> .<x>.>.;;
+ - : ('a, 'b -> ('c, 'b) code) code = .<fun (x_1) -> .<(x_1)>.>.
+
+Fri May 16 14:54:22 BST 2003
+ BUG: standalone bytecode compiling does not work with tag elimination
+ e.g. ./ocamlc toplevel/toplevellib.cma mex/evaletag.mk; ./a.out
+ PROBLEM: Tooploop.etag gets a typing error because timestamp of the code is in
+ the future (similar problem in the past with run)
+ FIXED: current timestamp bumped with the timestamp of the env passed to etag
+
+Mon Nov 25 18:24:28 GMT 2002
+ BUG: error typecore.ml: Texp_construct expected
+ PROBLEM: somehow typechecked made restrictive assuptions on the contents of the pexp_ext field for the case pPexp_construct
+ FIXED: assumptions relaxed
+
+Mon Nov 25 10:10:32 GMT 2002
+ BUG: csp of array ops gives internal errors
+ PROBLEM: arrays are treated in a special way after typechecking phase, so replacing an op with a csp val of the op changes the semantics. Use ocamlc -dlambda to see how array ops are treated internally.
+ FIXED: csp of array is rebuilt, like a Pervasives, so it's type-checked again, and the second phase of the compiler is happy.
+
+Thu Oct 24 09:55:36 BST 2002
+ BUG: csp at level n+2 gives Segmentation fault
+ PROBLEM: now Trx.mkcsp takes 2 args and not one, forgot to change cases
+ instvar and cspval at level n+1 accordingly
+ FIXED: cases instvar and cspvar at level n+1 now pass a second argument (None)
+
+Wed Oct 2 08:39:04 BST 2002
+ BUG: occurrences of a csp value share the same instantiated type
+ APPEARED: when treating Pervasives.* in a special way for performance. The
+ type of e.g. Pervasives.! is recorded in the extra field as an instantiated
+ type, so applications of the value cause unification.
+ BACKGROUND: values' types are closed schemas (all the identifiers are generic).
+ During type checking the types are instantiated. Instantiation is idempotent,
+ so one should always carry the schema somewhere. A typed expression exp such
+ that exp.exp_desc = Texp_ident (ident,value_description) has an instantiated
+ type in exp.exp_type and the type schema in value_description.val_type.
+ FIXED: Trx.trx creates a new instantiation for csp idents; Typecore.type_exp
+ re-instantiates the type schema when type-checking a cspval
diff -Naur ocaml-4.02.1/metalib/README ocaml-ber-n102/metalib/README
--- ocaml-4.02.1/metalib/README 1970-01-01 01:00:00.000000000 +0100
+++ ocaml-ber-n102/metalib/README 2015-01-10 16:27:06.936030975 +0000
@@ -0,0 +1,152 @@
+ BER MetaOCaml
+ N102 December 2014
+
+0. TABLE OF CONTENTS
+
+ 1 Copyright
+ 2 Installation
+ 3 Staging constructs
+ 4 Restrictions and Common Problems
+ 5 Detailed Discussion
+ 6 Credits
+
+1. COPYRIGHT
+
+BER MetaOCaml is a complete re-implementation of MetaOCaml,
+which was licensed according to ORIGINAL-LICENSE-META
+
+
+2. INSTALLATION
+
+ Please see the file INSTALL
+
+
+3. STAGING CONSTRUCTS
+ (This is a modified version of the section from the last
+ release of the original MetaOCaml, Feb 3, 2006)
+
+ The three new constructs are
+
+ bracket: .< e >. to delay computation (to the future stage)
+ escape: .~ e to perform a computation within brackets
+ and splice-in the result
+ run: !. e to run a future-stage computation, or code, now
+
+ A special type constructor, called 'code' builds the type of
+ future-stage computations, or code expressions. For example,
+
+ # .< 2 + 4 >.;;
+ - : int code = .<2 + 4>.
+
+ The type constructor 'code' takes as its argument the type of the
+ future-stage expression. Future-stage expressions are executed later,
+ but are type-checked now. Therefore, the generated code is assuredly
+ well-typed.
+
+ Code fragments can be spliced into larger code contexts by using the
+ escape construct:
+
+ # let x = .< 2 + 4 >. in .< .~ x + .~ x >. ;;
+ - : int code = .<(2 + 4) + (2 + 4)>.
+
+ The escape construct takes an expression of type (t code) and
+ produces an expression of type t, but only inside of a
+ code-constructing context (i.e., inside inside code brackets).
+ Attempting to escape code outside of a code-building context results
+ in the following type error:
+
+ # .~ .< 2 + 3 >.;;
+ Characters 0-14:
+ .~ .< 2 + 3 >.;;
+ ^^^^^^^^^^^^^^
+ Wrong level: escape at level 0
+
+
+ The run construct takes a code value, executes it and returns its result.
+ It is actually an ordinary function Runcode.run, which is also bound
+ to the prefix operation (!.). These operations are in the module
+ Runcode (which is not opened by default). For example:
+
+ # Runcode.run .< 2 + 3 >.;;
+ - : int = 5
+ # open Runcode;;
+ # !. .<fun x y -> x + y >. 2 3;;
+ - : int = 5
+
+ The run construct only works on closed code values. Attempting to run
+ open code leads to an exception in the generator (which can be traced
+ as any other exception).
+
+ # .< fun x -> .~ (let u = !. .< x >. in .<()>.) >.;;
+ Exception:
+ Failure
+ "The code built at Characters 7-8:
+ .< fun x -> .~ (let u = !. .< x >. in .<()>.) >.;;
+ ^
+ is not closed: identifier x_91 bound at Characters 7-8:
+ .< fun x -> .~ (let u = !. .< x >. in .<()>.) >.;;
+ ^
+ is free".
+
+ Please see many more examples in test/trivial.ml and other files
+ in the test/ directory.
+
+
+4. RESTRICTIONS AND COMMON PROBLEMS
+
+ 1. All data constructors and record labels used within brackets must
+ come from the types that are declared in separately compiled modules.
+ For example, the following works:
+ .<true>. (* data constructor is Pervasive *)
+ .<Some [1]>. (* ditto *)
+ .<{Complex.re = 1.0; im = 2.0}>. (* The Record Complex is defined *)
+ (* in the standard library. *)
+ open Complex (* which is separately complied *)
+ .<{re = 1.0; im = 2.0}>.
+
+ But the following are not allowed and flagged as compile-time error:
+
+ type foo = Bar
+ .<Bar>.
+
+ module Foo = struct exception E end
+ .<raise Foo.E>.
+
+ The type declaration foo or the module declaration Foo must be
+ moved into a separate file. The corresponding .cmi file must also be
+ available at run-time: either placed into the same directory as
+ the executable, or somewhere within the OCaml library search
+ path.
+
+ 2. Escaped expressions at the same level evaluate in the same
+ order as arguments in an application. For byte-code OCaml,
+ this order is RIGHT to left.
+
+ 3. Objects and modules are not supported within brackets
+ (but you can use brackets within modules or objects).
+
+
+5. DETAILED DISCUSSION
+
+ For differences from the original MetaOCaml and further discussion,
+ see NOTES.txt.
+
+
+6. CREDITS
+
+ BER MetaOCaml is a complete re-implementation of the original MetaOCaml.
+
+ The original MetaOCaml was funded primarily by an NSF project titled:
+
+ "ITR/SY(CISE): Putting Multi-Stage Annotations to Work"
+
+ That project was led by Walid Taha. Most of the original development
+ and implementation of staging was done by Cristiano
+ Calcagno, then at Imperial College.
+ Edward Pizzi has implemented the pretty-printing of code -- which
+ since then has been extensively modified and maintained by
+ Jacques Carette.
+ Xavier Leroy, INRIA, helped with the compiler specifics.
+
+ Many members of the metaocaml-users and metaocaml-hackers lists have
+ helped identify bugs and in some cases fixed them.
diff -Naur ocaml-4.02.1/metalib/reify_type.ml ocaml-ber-n102/metalib/reify_type.ml
--- ocaml-4.02.1/metalib/reify_type.ml 1970-01-01 01:00:00.000000000 +0100
+++ ocaml-ber-n102/metalib/reify_type.ml 2015-01-10 16:27:06.936030975 +0000
@@ -0,0 +1,197 @@
+(* Reifying (and printing) the type of a code expression *)
+(* This code illustrates type introspection facilities *)
+
+#directory "../parsing";;
+#directory "../typing";;
+#directory "../toplevel";;
+#directory "../utils";;
+
+(* This must be loaded first! It is stateful, and affects Predef *)
+#load "ident.cmo";;
+
+(* Load the rest of the compiler *)
+#load "misc.cmo";;
+#load "path.cmo";;
+#load "types.cmo";;
+#load "btype.cmo";;
+#load "tbl.cmo";;
+#load "subst.cmo";;
+#load "predef.cmo";;
+#load "datarepr.cmo";;
+#load "config.cmo";;
+#load "consistbl.cmo";;
+#load "clflags.cmo";;
+#load "env.cmo";;
+#load "ctype.cmo";;
+#load "printast.cmo";;
+#load "oprint.cmo";;
+#load "primitive.cmo";;
+#load "printtyp.cmo";;
+
+open Ident (* Just to make sure Ident is loaded first! *)
+open Types;;
+open Typedtree;;
+open Format
+;;
+
+(* Obtain the information about the type and the typing environment *)
+let get_type_env = function
+ {Parsetree.pexp_ext = Some tr} ->
+ let t : Typedtree.expression = Obj.obj tr in
+ (t.Typedtree.exp_type, t.Typedtree.exp_env)
+ | _ -> failwith "get_type_env"
+;;
+
+let describe_decl ppf env = function
+ | (Path.Pident id) as p ->
+ begin
+ try
+ let decl = Env.find_type p env in
+ Printtyp.type_declaration id ppf decl
+ with Not_found -> fprintf ppf "not found\n"
+ end
+ | _ -> fprintf ppf "not an ident"
+;;
+
+let rec describe_type ppf env ty =
+ let ty = Btype.repr ty in
+ match ty.desc with
+ | Tvar -> fprintf ppf "Tvar\n"
+ | Tarrow(l, _, _, _) when not (l = "") ->
+ fprintf ppf "Labelled arrow\n"
+ | Tarrow(l, ty1, ty2, _) ->
+ fprintf ppf "Arrow:\n";
+ describe_types ppf env [ty1;ty2]
+ | Ttuple tyl ->
+ fprintf ppf "Tuple:\n";
+ describe_types ppf env tyl
+ | Tconstr(p, tyl, abbrev) ->
+ fprintf ppf "Constructor:\n";
+ Printtyp.path ppf p;
+ describe_types ppf env tyl;
+ describe_decl ppf env p;
+ fprintf ppf "\n"
+ | Tvariant row ->
+ fprintf ppf "TVariant\n"
+ | Tobject (fi, nm) ->
+ fprintf ppf "Tobject\n"
+ | Tsubst ty ->
+ describe_type ppf env ty
+ | Tlink _ | Tnil | Tfield _ ->
+ failwith "describe_type"
+ | Tpoly (ty, []) ->
+ describe_type ppf env ty
+ | Tpoly (ty, tyl) ->
+ fprintf ppf "Tpoly\n"
+ | Tunivar ->
+ fprintf ppf "Tunivar\n"
+and describe_types ppf env tyl =
+ List.iter (describe_type ppf env) tyl;
+ fprintf ppf "\n"
+;;
+
+let do_describe cde =
+ let (t,tenv) = get_type_env (Obj.magic cde) in
+ describe_type std_formatter tenv t;;
+
+
+(* tests *)
+
+type t1 = A of int | B of bool list;;
+
+let t1exp' () = (failwith "na" : t1);;
+
+do_describe .<t1exp'>.;;
+
+(*
+Arrow:
+Constructor:
+unit
+type unit = ()
+Constructor:
+t1
+type t1 =
+ A of int
+ | B of bool list
+*)
+
+type 'a t2 = | A of t1 | B of 'a;;
+let t2exp' () = (failwith "na" : 'a t2);;
+
+do_describe .<t2exp'>.;;
+
+(*
+Arrow:
+Constructor:
+unit
+type unit = ()
+Constructor:
+t2Tvar
+
+type 'a t2 =
+ A of t1
+ | B of 'a
+
+*)
+
+
+(*
+module Units : sig
+ type 'a t
+ val to_feet : float -> [`Feet ] t
+ val to_meters : float -> [`Meters] t
+ val add : 'a t -> 'a t -> 'a t
+ val print : 'a t -> unit
+end = struct
+ type 'a t = float
+ let to_feet x=x
+ let to_meters x=x
+ let add x y = x +. y
+ let print (x : 'a t) = Printf.printf "%f (units)" x;
+ do_describe .<x>.
+end;;
+open Units;;
+
+let test_unit = print (add (to_meters 1.) (to_meters 2.));;
+
+module Units1 : sig
+ type 'a t
+ val to_feet : float -> [`Feet ] t
+ val to_meters : float -> [`Meters] t
+ val add : 'a t -> 'a t -> 'a t
+ val print : 'a t -> unit
+end = struct
+ type 'a t = float
+ let to_feet x=x
+ let to_meters x=x
+ let add x y = x +. y
+ let print (x : 'a t) = Printf.printf "%f (units)" x;
+ .! .<do_describe .<x>.>.
+end;;
+open Units1;;
+
+let printx (x : 'a t) = .! .<do_describe .~(let v = .<x>. in .<v>.)>.;;
+let tt = printx (to_meters 1.);;
+
+
+let test_unit1 = print (add (to_meters 1.) (to_meters 2.));;
+
+let x = to_meters 1. in do_describe .<x>.;;
+
+type 'a ft = int;;
+type uf;;
+type um;;
+
+
+let printfx (x : 'a ft) = .! .<do_describe .~(let v = .<x>. in .<[v]>.)>.;;
+
+let printfx (x : 'a ft) = let v = .<[x]>. in .! .<do_describe v>.;;
+let tt = printfx (1 : uf ft);;
+
+let printfx (x : 'a ft) = let v1 = .<[x]>. in
+ do_describe ((.! v1));;
+
+
+let v = .<[x]>. in .! .<do_describe v>.;;
+
+*)
diff -Naur ocaml-4.02.1/metalib/reify_type.mli ocaml-ber-n102/metalib/reify_type.mli
--- ocaml-4.02.1/metalib/reify_type.mli 1970-01-01 01:00:00.000000000 +0100
+++ ocaml-ber-n102/metalib/reify_type.mli 2015-01-10 16:27:06.936030975 +0000
@@ -0,0 +1,5 @@
+(* Reifying (and printing) the type of a code expression *)
+(* This code illustrates type introspection facilities *)
+
+(* Print code values *)
+val describe_type_of : Format.formatter -> ('c,'a) code -> unit
diff -Naur ocaml-4.02.1/metalib/runcode.ml ocaml-ber-n102/metalib/runcode.ml
--- ocaml-4.02.1/metalib/runcode.ml 1970-01-01 01:00:00.000000000 +0100
+++ ocaml-ber-n102/metalib/runcode.ml 2015-01-10 16:27:06.936030975 +0000
@@ -0,0 +1,161 @@
+(* Run the closed code: byte-code and native code *)
+
+open Format
+
+type 'a closed_code = Trx.closed_code_repr
+
+
+(* Add a directory to search for .cmo/.cmi files, needed
+ for the sake of running the generated code .
+ The specified directory is prepended to the load_path.
+*)
+let add_search_path : string -> unit = fun dir ->
+ let dir = Misc.expand_directory Config.standard_library dir in
+ Config.load_path := dir :: !Config.load_path;
+ Dll.add_path [dir];
+ Env.reset_cache ()
+
+
+(* Check that the code is closed and return the closed code *)
+let close_code : 'a code -> 'a closed_code = fun cde ->
+ Trx.close_code_repr (Obj.magic cde)
+
+(* The same as close_code but return the closedness check as a thunk
+ rather than performing it.
+ This is useful for debugging and for showing the code.
+*)
+let close_code_delay_check : 'a code -> 'a closed_code * (unit -> unit) =
+ fun cde -> Trx.close_code_delay_check (Obj.magic cde)
+
+let open_code : 'a closed_code -> 'a code = fun ccde ->
+ Obj.magic (Trx.open_code ccde)
+
+
+(* Execute a thunk (which does compilation) while disabling certain
+ warnings.
+*)
+let warnings_descr =
+ [(Warnings.Partial_match "",("P","p"));
+ (Warnings.Unused_argument,("X","x"));
+ (Warnings.Unused_var "",("Y","y"));
+ (Warnings.Unused_var_strict "",("Z","z"))
+ ]
+
+let with_disabled_warnings warnings thunk =
+ let disable_str =
+ String.concat ""
+ (List.map
+ (fun w -> snd (List.assoc w warnings_descr)) warnings) in
+(*
+ let curr_str =
+ String.concat ""
+ (List.map
+ (fun w ->
+ let state = Warnings.is_active w in
+ (if state then fst else snd) (List.assoc w warnings_descr))
+ warnings) in
+*)
+ let warnings_old = Warnings.backup () in
+ let () = Warnings.parse_options false disable_str in
+ try
+ let r = thunk () in
+ Warnings.restore warnings_old; r
+ with e ->
+ Warnings.restore warnings_old;
+ raise e
+
+
+let initial_env = ref Env.empty
+
+(* Load and execute bytecode: copied from toploop/toploop.ml *)
+let load_lambda ppf lam =
+ if !Clflags.dump_rawlambda then fprintf ppf "%a@." Printlambda.lambda lam;
+ let slam = Simplif.simplify_lambda lam in
+ if !Clflags.dump_lambda then fprintf ppf "%a@." Printlambda.lambda slam;
+ let (init_code, fun_code) = Bytegen.compile_phrase slam in
+ if !Clflags.dump_instr then
+ fprintf ppf "%a%a@."
+ Printinstr.instrlist init_code
+ Printinstr.instrlist fun_code;
+ let (code, code_size, reloc) = Emitcode.to_memory init_code fun_code in
+ let can_free = (fun_code = []) in
+ let initial_symtable = Symtable.current_state() in
+ Symtable.patch_object code reloc;
+ Symtable.check_global_initialized reloc;
+ Symtable.update_global_table();
+ (* let initial_bindings = !toplevel_value_bindings in *)
+ try
+ Toploop.may_trace := true;
+ let retval = (Meta.reify_bytecode code code_size) () in
+ Toploop.may_trace := false;
+ if can_free then begin
+ Meta.static_release_bytecode code code_size;
+ Meta.static_free code;
+ end;
+ retval
+ with x ->
+ Toploop.may_trace := false;
+ if can_free then begin
+ Meta.static_release_bytecode code code_size;
+ Meta.static_free code;
+ end;
+ (* let initial_bindings = !toplevel_value_bindings in *)
+ Symtable.restore_state initial_symtable;
+ raise x
+
+(* Patterned after toploop.ml:execute_phrase *)
+
+let typecheck_code' : Parsetree.expression -> Typedtree.structure = fun exp ->
+ if !initial_env = Env.empty then begin
+ let old_time = Ident.current_time() in
+ (* does Ident.reinit() and may corrupt the timestamp if we
+ run in top-level. See Ident.reinit code
+ *)
+ initial_env := Compmisc.initial_env();
+ Ident.set_current_time old_time
+ end;
+ (* Ctype.init_def(Ident.current_time()); *)
+ let ppf = std_formatter in
+ with_disabled_warnings [Warnings.Partial_match "";
+ Warnings.Unused_argument;
+ Warnings.Unused_var "";
+ Warnings.Unused_var_strict ""]
+ (fun () ->
+ let sstr = [Ast_helper.Str.eval exp] in
+ if !Clflags.dump_source then Pprintast.structure ppf sstr;
+ try
+ begin
+ Typecore.reset_delayed_checks ();
+ let (str, sg, newenv) = Typemod.type_toplevel_phrase !initial_env sstr in
+ if !Clflags.dump_typedtree then Printtyped.implementation ppf str;
+ let sg' = Typemod.simplify_signature sg in
+ if !Clflags.dump_typedtree then Printtyp.signature ppf sg';
+ ignore (Includemod.signatures !initial_env sg sg');
+ Typecore.force_delayed_checks (); str
+ end
+ with
+ x -> (Errors.report_error ppf x;
+ Format.pp_print_newline ppf ();
+ failwith
+ "Error type-checking generated code: scope extrusion?")
+ )
+
+(* For the benefit of offshoring, etc. *)
+let typecheck_code : 'a closed_code -> Typedtree.expression = fun cde ->
+ let str = typecheck_code'
+ (cde : Trx.closed_code_repr :> Parsetree.expression) in
+ match str.Typedtree.str_items with
+ | [{Typedtree.str_desc = Typedtree.Tstr_eval (texp,_)}] -> texp
+ | _ -> failwith "cannot happen: Parsetree was not an expression?"
+
+let run_bytecode : 'a closed_code -> 'a = fun cde ->
+ let str = typecheck_code'
+ (cde : Trx.closed_code_repr :> Parsetree.expression) in
+ let lam = Translmod.transl_toplevel_definition str in
+ Warnings.check_fatal ();
+ Obj.obj @@ load_lambda Format.std_formatter lam
+
+(* Abbreviations for backwards compatibility *)
+let run cde = run_bytecode (close_code cde)
+let (!.) cde = run cde
+
diff -Naur ocaml-4.02.1/metalib/runcode.mli ocaml-ber-n102/metalib/runcode.mli
--- ocaml-4.02.1/metalib/runcode.mli 1970-01-01 01:00:00.000000000 +0100
+++ ocaml-ber-n102/metalib/runcode.mli 2015-01-10 16:27:06.936030975 +0000
@@ -0,0 +1,42 @@
+(* Given a closed code expression, compile and run it, returning
+ its result or propagating raised exceptions.
+*)
+
+type 'a closed_code = Trx.closed_code_repr
+
+(* Check that the code is closed and return the closed code *)
+val close_code : 'a code -> 'a closed_code
+
+(* The same as close_code but return the closedness check as a thunk
+ rather than performing it.
+ This is useful for debugging and for showing the code:
+ If there is a scope extrusion error, it is still useful
+ to show the code with the extrusion before throwing the scope-extrusion
+ exception.
+*)
+val close_code_delay_check : 'a code -> 'a closed_code * (unit -> unit)
+
+(* Total: a closed code can always be used in slices, etc. *)
+val open_code : 'a closed_code -> 'a code
+
+(* Type-check the generated code and return the typed tree.
+ Offshoring takes it from here.
+*)
+val typecheck_code : 'a closed_code -> Typedtree.expression
+
+(* Run closed code by bytecode compiling it and then executing *)
+val run_bytecode : 'a closed_code -> 'a
+
+(* Other ways of running are equally possible *)
+
+(* The following two synonyms are for backwards compatibility:
+ They are both compositions of close_code and run_bytecode *)
+val run : 'a code -> 'a
+val (!.) : 'a code -> 'a
+
+(* Add a directory to search for .cmo/.cmi files, needed
+ for the sake of running the generated code.
+ The directory name may be given as +dir to refer to stdlib.
+ The specified directory is prepended to the load_path.
+*)
+val add_search_path : string -> unit
diff -Naur ocaml-4.02.1/metalib/run_native.ml ocaml-ber-n102/metalib/run_native.ml
--- ocaml-4.02.1/metalib/run_native.ml 1970-01-01 01:00:00.000000000 +0100
+++ ocaml-ber-n102/metalib/run_native.ml 2015-01-10 16:27:06.936030975 +0000
@@ -0,0 +1,214 @@
+(* Support for running natively compiled code *)
+
+(*
+Here we collect various fragments, to be work on later.
+
+The first fragment used to be in driver/optcompile.ml. It is definitely
+a hack! Rather than patch every implementation file with extra code to
+restore the array of CSP values, we should create a (perhaps C)
+code file that maintains the CSP array, storing and restoring it as needed,
+probably as part of initialization.
+That code file will be linked in with the whole project (forcibly linked,
+via the -linkall option).
+The Trx module will refer to the name of the CSP array, when processing
+CSPs in the native code.
+*)
+
+open Parsetree
+let local_csp_arr_name = "local_csp_arr_hwrrekjhj"
+let local_csp_arr_str () =
+ let exp = {pexp_desc = Obj.magic ();
+ pexp_loc = Location.none;
+ pexp_ext = None }
+ and pat = {ppat_desc = Obj.magic ();
+ ppat_loc = Location.none;
+ ppat_ext = None } in
+ let exp1 = {exp with pexp_desc = Pexp_ident (Longident.Ldot (Longident.Lident "Marshal", "from_string"))}
+ and exp2 = {exp with pexp_desc = Pexp_constant (Asttypes.Const_string "blaaaaah!")}
+ and exp0 = {exp with pexp_desc = Pexp_constant (Asttypes.Const_int 0)} in
+ let exp3 = {exp with pexp_desc = Pexp_apply ( exp1, [("",exp2);("",exp0)])} in
+ let pat1 = {pat with ppat_desc = Ppat_var local_csp_arr_name} in
+ let str1 = {pstr_desc = Pstr_value (Asttypes.Nonrecursive,[pat1,exp3]);
+ pstr_loc = Location.none} in
+ let pat2 = {pat with ppat_desc = Ppat_any} in
+ let exp4 = {exp with pexp_desc = Pexp_ident (Longident.Lident local_csp_arr_name)} in
+ let str2 = {pstr_desc = Pstr_value (Asttypes.Nonrecursive,[pat2,exp4]);
+ pstr_loc = Location.none} in
+ let _ = Trx.reset_csp_array ()
+ in [str1;str2]
+
+let find_local_csp_arr_texp =
+ function | Tstr_value (_,[p,e]) -> e
+ | _ -> assert false
+
+let hack_csp_arr_str = function
+ | Tstr_value (rf,[p,e]) ->
+ Tstr_value (rf,[p,{e with exp_desc =
+ begin
+ match e.exp_desc with
+ | Texp_apply (e,[(Some e1,o);a]) ->
+ Texp_apply (e,[(Some {e1 with exp_desc =
+ begin
+ match e1.exp_desc with
+ | Texp_constant (Asttypes.Const_string "blaaaaah!") ->
+ let s = Marshal.to_string !Trx.csp_array []
+ in Texp_constant (Asttypes.Const_string s)
+ | _ -> assert false
+ end}, o);a])
+ | _ -> assert false
+ end}])
+ | _ -> assert false
+
+let process_str str =
+ Trx.initial_native_compilation := true;
+ if !Clflags.plain_ocaml then str
+ else let str2 = List.hd(List.tl str)
+ in Trx.local_csp_arr_texp := (find_local_csp_arr_texp str2);
+ let str' = Trx.trx_structure str
+ in (hack_csp_arr_str (List.hd str'))::(List.tl str')
+
+(*The local_csp_arr_str was hooked up in optcompile.ml before
+ Typemod.type_implementation:
+ ++ (fun str ->(if !Clflags.plain_ocaml then str else (local_csp_arr_str ()@str))) (* XXO *)
+and process_str was hooked up after Typemod.type_implementation
+*)
+
+
+let plugin_count = ref 0
+let execute_expression_native exp =
+ init_path ();
+ begin (* Update the global ident timestamp *)
+ match exp.pexp_ext with
+ | Some v -> let t = Env.get_ident_timestamp (Obj.magic v).exp_env
+ in Ident.set_current_time t
+ | None -> ()
+ end;
+ Ctype.init_def(Ident.current_time());
+ let exp1 = { exp with pexp_desc = Pexp_ident (Longident.Ldot
+ (Longident.Lident "Trx", "execute_expression_result")) } in
+ let exp2 = { exp with pexp_desc = Pexp_ident (Longident.Lident ":=") } in
+ let exp3 = { exp with pexp_desc = Pexp_ident (Longident.Ldot
+ (Longident.Lident "Obj", "magic")) } in
+ let exp4 = { exp with pexp_desc = Pexp_apply ( exp3, [("",exp)]) } in
+ let exp5 = { exp with pexp_desc = Pexp_apply ( exp2,
+ [("",exp1);("",exp4)]) } in
+ let ppf = Format.std_formatter in
+ let sourcefile = begin
+ incr plugin_count;
+ "plugin" ^ (string_of_int !plugin_count) ^ ".ml"
+ end in
+ let prefixname = Misc.chop_extension_if_any sourcefile in
+ let modulename = String.capitalize(Filename.basename prefixname) in
+ let inputfile = Pparse.preprocess sourcefile in
+ let env = initial_env() in
+ Compilenv.reset modulename;
+ (* Clflags.keep_asm_file := true; *)
+ try
+ [{ Parsetree.pstr_desc = Parsetree.Pstr_eval exp5;
+ Parsetree.pstr_loc = Location.none }]
+ ++ Typemod.type_implementation sourcefile prefixname modulename env
+ (* The following should not be needed: we added Trx pre-processing
+ already in the type checker.
+ *)
+ ++ (fun (str,coe) -> (Trx.trx_structure str, coe)) (* XXO *)
+ ++ Translmod.transl_store_implementation modulename
+ +++ print_if ppf Clflags.dump_rawlambda Printlambda.lambda
+ +++ Simplif.simplify_lambda
+ +++ print_if ppf Clflags.dump_lambda Printlambda.lambda
+ ++ Asmgen.compile_implementation prefixname ppf;
+ Compilenv.save_unit_info (prefixname ^ ".cmx");
+ Warnings.check_fatal ();
+ Pparse.remove_preprocessed inputfile;
+ !Trx.load_compiled_code_hook !plugin_count;
+ !Trx.execute_expression_result
+ with x ->
+ Pparse.remove_preprocessed_if_ast inputfile;
+ raise x
+
+let _ = Trx.native_mode := true
+let _ = Trx.execute_expression_hook := execute_expression_native
+
+
+(* The following code is moved from trx.ml *)
+let pathval_trx_get_csp_value = lazy(find_value "Trx.get_csp_value")
+let pathval_array_get = lazy(find_value "Array.get")
+let trx_array_get exp =
+ let (p, v) = Lazy.force pathval_array_get in
+ { exp with exp_type = instance v.val_type;
+ exp_desc = Texp_ident(p, v) }
+
+let trx_get_csp_value exp =
+ let (p, v) = Lazy.force pathval_trx_get_csp_value in
+ { exp with exp_type = instance v.val_type;
+ exp_desc = Texp_ident(p, v) }
+
+let initial_native_compilation = ref false
+let execute_expression_hook = ref (fun _ -> assert false)
+let execute_expression_result = ref (Obj.repr 7)
+let execute_expression e = !execute_expression_hook e
+let load_compiled_code_hook = ref (fun n -> ())
+
+let empty_csp_array = Array.create 1000 (Obj.repr ())
+let csp_array = ref (Array.copy empty_csp_array)
+let csp_index = ref 0
+let reset_csp_array () =
+ csp_array := Array.copy empty_csp_array;
+ csp_index := 0
+let csp_arr_filename = "saved_csp_array"
+
+let save_csp_array () = if !csp_index <> 0 then
+ let outchan = open_out csp_arr_filename in
+ let v = (!csp_index, !csp_array)
+ in Marshal.to_channel outchan v []; close_out outchan
+
+let load_csp_array () =
+ let inchan = open_in csp_arr_filename in
+ let (len,a) = Marshal.from_channel inchan
+ in csp_index := len; csp_array := a;
+ close_in inchan
+
+let add_csp_value (v,l) =
+ begin
+ if (!csp_index >= (Array.length !csp_array))
+ then csp_array := Array.append !csp_array empty_csp_array
+ end;
+ !csp_array.(!csp_index) <- v;
+ incr csp_index;
+ !csp_index - 1
+
+let get_csp_value n = !csp_array.(n)
+
+
+let local_csp_arr_texp = ref (Obj.magic ())
+
+
+let remove_texp_cspval exp =
+ if !native_mode = false then exp else
+ failwith "native mode CSP are not impemented yet"
+(*
+ ZZZ
+ match exp.exp_desc with
+ | Texp_cspval (v,l) ->
+ let i = add_csp_value (v,l) in
+ let exp' = {exp with exp_desc = Texp_constant (Const_int i)} in
+ let desc = if !initial_native_compilation
+ then (Texp_apply (trx_array_get exp, [(Some !local_csp_arr_texp, Required);(Some exp', Required)]))
+ else (Texp_apply (trx_get_csp_value exp, [(Some exp', Required)])) in
+ {exp with exp_desc = desc}
+ | _ -> assert false
+*)
+
+
+(*
+ Moved from trx.mli
+val native_mode : bool ref
+val initial_native_compilation : bool ref
+val get_csp_value : int -> Obj.t
+val execute_expression_hook : (Parsetree.expression -> Obj.t) ref
+val load_compiled_code_hook : (int -> unit) ref
+val execute_expression_result : Obj.t ref
+val execute_expression : Parsetree.expression -> Obj.t
+val csp_array : Obj.t array ref
+val reset_csp_array : unit -> unit
+val local_csp_arr_texp : Typedtree.expression ref
+*)
diff -Naur ocaml-4.02.1/metalib/simple.ref ocaml-ber-n102/metalib/simple.ref
--- ocaml-4.02.1/metalib/simple.ref 1970-01-01 01:00:00.000000000 +0100
+++ ocaml-ber-n102/metalib/simple.ref 2015-01-10 16:27:06.936030975 +0000
@@ -0,0 +1,40 @@
+BER MetaOCaml toplevel, version N 102
+ OCaml version 4.02.1
+
+# # val tr1 : ('a -> int) code = .<fun x_1 -> 1>.
+# * * val tr1' : ('a -> 'b -> 'b) code = .<fun x_2 -> fun x_3_4 -> x_3_4>.
+# * * val tr2 : ('a -> int) code = .<fun x_5 -> 1>.
+# * * Exception:
+Failure
+ "The code built at Characters 72-73:\n let tr3 = .<fun x -> .~(let x = !. .<x>. in .<x>.)>.;;\n ^\n is not closed: identifier x_6 bound at Characters 72-73:\n let tr3 = .<fun x -> .~(let x = !. .<x>. in .<x>.)>.;;\n ^\n is free".
+# * * * * * * * * * Error was expected
+- : unit = ()
+# Exception:
+Failure
+ "The code built at Characters 8-9:\n .< fun x -> .~ (!. .< x >.) >.;;\n ^\n is not closed: identifier x_7 bound at Characters 8-9:\n .< fun x -> .~ (!. .< x >.) >.;;\n ^\n is free".
+# * * * * * * * * * * Error was expected
+- : unit = ()
+# Characters 36-37:
+ let tr4 = .<fun x -> .~(let x = !. x in .<x>.)>.;;
+ ^
+Wrong level: variable bound at level 1 and used at level 0
+# * * * * * Error was expected
+- : unit = ()
+# val tr5 : ('a -> int) code = .<fun x_8 -> Runcode.(!.) .< 1 >.>.
+# * * # val tr6 : ('a -> 'a) code = .<fun x_9 -> Runcode.(!.) .< x_9 >.>.
+# * * # val tr7 : ('a code -> 'a) code = .<fun x_10 -> Runcode.(!.) x_10>.
+# * * * * * * * * * # val tr8 : ('a -> 'a code) code = .<fun x_11 -> (* CSP y *)>.
+# * * * * * * val tr8r : '_a -> '_a code = <fun>
+# * * * * * * * * * - : int code = .<x_11>.
+
+Failure("The code built at Characters 36-37:\n val tr8r : '_a -> '_a code = <fun>\n ^\n is not closed: identifier x_11 bound at Characters 36-37:\n val tr8r : '_a -> '_a code = <fun>\n ^\n is free")
+# * * * * Error was expected
+- : unit = ()
+# val tm1 : ('a -> 'a code) code = .<fun x_12 -> .< x_12 >.>.
+# * * - : int code = .<(* CSP x_12 *) Obj.magic 10>.
+# * * # val tg1 : '_a list ref = {contents = []}
+# * * * val tg2 : '_a list ref = {contents = []}
+# * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
+All Done
+- : unit = ()
+#
diff -Naur ocaml-4.02.1/metalib/test/bool2.ml ocaml-ber-n102/metalib/test/bool2.ml
--- ocaml-4.02.1/metalib/test/bool2.ml 1970-01-01 01:00:00.000000000 +0100
+++ ocaml-ber-n102/metalib/test/bool2.ml 2015-01-10 16:27:06.936030975 +0000
@@ -0,0 +1,8 @@
+type ('a,'b) staged = Now of 'b | Later of ('a, 'b) code
+
+(* It is the *presence* of this module with a nested module which
+ * causes the failure, even though it is empty and not used! *)
+module XXX = struct
+ module TT = struct
+ end
+end
diff -Naur ocaml-4.02.1/metalib/test/letrec.ml ocaml-ber-n102/metalib/test/letrec.ml
--- ocaml-4.02.1/metalib/test/letrec.ml 1970-01-01 01:00:00.000000000 +0100
+++ ocaml-ber-n102/metalib/test/letrec.ml 2015-01-10 16:27:06.936030975 +0000
@@ -0,0 +1,79 @@
+(* Generation of more efficient letrec code, without nesting of letrec *)
+(* This is the product of the discussion with Jun Inoue in Oct 2013 *)
+
+module type LETRECS = sig
+ type letrec_id (* abstract *)
+ val make_letrecs : (letrec_id -> 'w code) -> 'w code
+
+ val add_letrec : letrec_id ->
+ (('a->'b) code -> ('a->'b) code * 'w) -> 'w
+end
+
+ (* (('cl,'a->'b) code -> ('cl,'w) code) -> ('cl,'w) code *)
+
+(* Example of using the interface
+ First, the standard even-odd example
+ *)
+
+module Ex1(S:LETRECS) = struct
+ open S
+
+ let r =
+ make_letrecs @@ fun lid ->
+ add_letrec lid (fun even' ->
+ add_letrec lid (fun odd' ->
+ let even = .<fun n -> n = 0 || .~odd' (n-1)>.
+ and odd = .<fun n -> not (n=0) && .~even' (n-1)>.
+ in (odd, (even, .<fun n -> (.~odd n, .~even n)>.))
+ ))
+end
+
+(*
+ Next example:
+ It is the variation of the even-odd example; the mutually
+ recursive functions are (artificially) made to have distinct types
+
+ let rec even = fun n -> n=0 || odd even (n-1)
+ and odd even = not (n=0) && even (n-1)
+ in fun n -> [even n, odd n]
+
+The next two examples are to generalize the above to compute residuals of k
+for example
+
+let rec three0 n = n=0 || three2 (n-1)
+and three1 n = not (n=0) && three0 (n-1)
+and three2 n = not (n=0) && three1 (n-1)
+
+
+*)
+module Ex2(S:LETRECS) = struct
+ open S
+
+ let r k =
+ make_letrecs @@ fun lid ->
+ let rec loop = function
+ | k when k <= 0 -> .<[| |]>.
+ | 1 -> .<[| true |]>.
+ | k ->
+ add_letrec lid (fun even' ->
+ add_letrec lid (fun odd' ->
+ let even = .<fun n -> n = 0 || .~odd' (n-1)>.
+ and odd = .<fun n -> not (n=0) && .~even' (n-1)>.
+ in (odd, (even, .<fun n -> (.~odd n, .~even n)>.))
+ ))
+end
+
+
+(* One, naive implementation: a simultaneous letrec as nested letrecs *)
+module Nested : LETRECS = struct
+ type letrec_id = unit
+
+ let add_letrec : letrec_id ->
+ (('cl,'a->'b) code -> ('cl,'a->'b) code) ->
+ (('cl,'a->'b) code -> ('cl,'w) code) -> ('cl,'w) code =
+ fun lid exp body -> .<let rec x = .~(exp .<x>.) in .~(body .<x>.)>.
+
+ val make_letrecs : (letrec_id -> 'w code) -> 'w code
+ fun body -> body ()
+end;;
+
diff -Naur ocaml-4.02.1/metalib/test/pythagorian_triples.ml ocaml-ber-n102/metalib/test/pythagorian_triples.ml
--- ocaml-4.02.1/metalib/test/pythagorian_triples.ml 1970-01-01 01:00:00.000000000 +0100
+++ ocaml-ber-n102/metalib/test/pythagorian_triples.ml 2015-01-10 16:27:06.936030975 +0000
@@ -0,0 +1,87 @@
+(* Test of the let! notation: Fair monad for non-determinism *)
+
+module NonDet : sig
+ type 'a stream_v
+ type 'a stream = unit -> 'a stream_v
+
+ val ret : 'a -> 'a stream
+ val fail : 'a stream
+
+ (* a.k.a bind or disjunction *)
+ val (let!) : 'a stream -> ('a -> 'b stream) -> 'b stream
+ (* a.k.a. fair disjunction *)
+ val mplus : 'a stream -> 'a stream -> 'a stream
+
+ val guard : bool -> unit stream
+ val yield : 'a stream -> 'a stream
+
+ val run : int -> (* upper bound on the number of solutions *)
+ 'a stream ->
+ 'a list
+end = struct
+ type 'a stream_v =
+ Nil | Cons of 'a * 'a stream | InC of 'a stream
+ and 'a stream = unit -> 'a stream_v
+
+ let fail = fun () -> Nil
+ let ret a = fun () -> Cons (a,fail)
+
+ (* actually, interleave: a fair disjunction with breadth-first search*)
+ let rec mplus a b = fun () ->
+ match a () with
+ | Nil -> InC b
+ | Cons (a1,a2) -> Cons (a1,(mplus b a2))
+ | InC a ->
+ begin match b () with
+ | Nil -> InC a
+ | InC b -> InC (mplus a b)
+ | Cons (b1,b2) -> Cons (b1, (mplus a b2))
+ end
+
+ (* a fair conjunction *)
+ let rec (let!) m f = fun () ->
+ match m () with
+ | Nil -> fail ()
+ | InC a -> InC ((let!) a f)
+ | Cons (a,b) -> mplus (f a) ((let!) b f) ()
+
+ let guard be = if be then ret () else fail
+ let yield m () = InC m
+
+ let rec run n m =
+ if n = 0 then [] else
+ match m () with
+ | Nil -> []
+ | InC a -> run n a
+ | Cons (a,b) -> (a::run (n-1) b)
+end;;
+
+open NonDet;;
+
+(* The example uses left recursion and truly infinite streams! *)
+(* Don't try this in Prolog or in Haskell's MonadPlus. *)
+
+let rec numb () = (* infinite stream of integers *)
+ yield (mplus (let! n = numb in ret (n+1)) (* left recursion! *)
+ (ret 0)) ()
+;;
+
+let pyth : (int * int * int) NonDet.stream =
+ let! i = numb in
+ let! () = guard (i>0) in
+ let! j = numb in
+ let! () = guard (j>0) in
+ let! k = numb in
+ let! () = guard (k>0) in
+ (* Just to illustrate the `let' form within let! *)
+ let test x = x*x = j*j + k*k in
+ let! () = guard (test i) in
+ ret (i,j,k)
+;;
+
+let [(5, 4, 3); (5, 3, 4); (10, 8, 6); (10, 6, 8); (13, 12, 5); (13, 5, 12);
+ (15, 12, 9); (15, 9, 12); (17, 15, 8); (17, 8, 15)]
+ =
+run 10 pyth;;
+
+print_endline "\nAll done";;
diff -Naur ocaml-4.02.1/metalib/test/quick_test.ml ocaml-ber-n102/metalib/test/quick_test.ml
--- ocaml-4.02.1/metalib/test/quick_test.ml 1970-01-01 01:00:00.000000000 +0100
+++ ocaml-ber-n102/metalib/test/quick_test.ml 2015-01-10 16:27:06.936030975 +0000
@@ -0,0 +1,615 @@
+(* Quick test of BER MetaOCaml. From PEPM09 and PEPM08 papers:
+
+ Closing the Stage: From staged code to typed closures.
+ Yukiyoshi Kameyama, Oleg Kiselyov, and Chung-chieh Shan
+
+*)
+open Runcode;;
+
+(* ---------------------------------------------------------------------- *)
+(* The power example, Sec 2 *)
+
+let square x = x * x
+let rec power : int -> int code -> int code =
+ fun n -> fun x ->
+ if n = 0 then .<1>.
+ else if n mod 2 = 0
+ then .< (*csp*)square .~(power (n/2) x)>.
+ else .<.~x * .~(power (n-1) x)>.
+;;
+let power7_cde = .<fun x -> .~(Printf.printf "power\n"; power 7 .<x>.)>.;;
+(* "power" printed once *)
+(*
+val power7_cde : (int -> int) code = .<
+ fun x_22 ->
+ x_22 *
+ (((* cross-stage persistent value (id: square) *))
+ (x_22 *
+ (((* cross-stage persistent value (id: square) *)) (x_22 * 1))))>.
+*)
+let power7 : int -> int = !. power7_cde;;
+let (128, 2187) = (power7 2, power7 3);;
+(* nothing is printed...
+ val res : int * int = (128, 2187)
+*)
+
+(* Before N101, the following didn't work *)
+let power7 : int -> int =
+ !. .<fun x -> .~(Printf.printf "power\n"; power 7 .<x>.)>.;;
+
+(* But the following does. It is the explicit version of the above *)
+let power7 : int -> int =
+ Runcode.run_bytecode (Runcode.close_code
+ .<fun x -> .~(Printf.printf "power\n"; power 7 .<x>.)>.);;
+(* "power" printed once *)
+let (128, 2187) = (power7 2, power7 3);;
+(* nothing is printed...
+ val res : int * int = (128, 2187)
+*)
+
+
+(* ---------------------------------------------------------------------- *)
+(* The ef example. *)
+
+(* The source code *)
+let ef = fun z -> .<fun x -> .~z + x>.;;
+let ef1 = .<fun y -> .~(ef .<y>.)>.;;
+(*
+val ef1 : (int -> int -> int) code = .<fun y_27 x_28 -> y_27 + x_28>.
+*)
+let 5 = (!. ef1) 2 3;; (* 5 *)
+
+let ef2 = .<fun x -> fun y -> .~(ef .<x*y>.)>.;;
+(*
+val ef2 : (int -> int -> int -> int) code = .<
+ fun x_29 y_30 x_31 -> (x_29 * y_30) + x_31>.
+*)
+let 10 = (!. ef2) 2 3 4;; (* 10 *)
+
+(* ---------------------------------------------------------------------- *)
+(* The eta example. *)
+
+let (5,10,34) =
+ let eta f = .<fun x -> .~(f .<x>.)>. in
+ (!.
+ .< fun y ->
+ .~(eta (fun z -> .< .~z + y >.)) >.)
+ 2 3,
+ (!.
+ .< fun y -> fun w ->
+ .~(eta (fun z -> .< .~z + y*w >.)) >.)
+ 2 3 4,
+ (!.
+ .< fun x u ->
+ .~(eta (fun z -> .<fun y -> .~z + u*x*y >.)) >.)
+ 2 3 4 5
+ ;;
+
+
+(* ---------------------------------------------------------------------- *)
+(* Cross-stage presistence *)
+
+(* This example includes persistence of a code value, which we
+ specifically exclude in the paper. *)
+
+let cspe =
+ .<fun x -> .~(let u = .<x>. in
+ (!. .<fun y -> .<.~u>.>.) ()) >.;;
+
+(*
+ val cspe : ('a -> 'a) code = .<fun x_41 -> x_41>.
+*)
+
+let 42 = (!. cspe) 42;;
+
+(* This CSP example does fit our restriction *)
+
+let rec scspe x = .<(fun y -> x) (scspe 1)>.;;
+(*
+val scspe : int -> int code = <fun>
+# scspe 10;;
+- : ('a, int) code =
+.<((fun y_1 -> 10) (((* cross-stage persistent value (as id: scspe) *)) 1))>.
+# !. (scspe 10);;
+- : int = 10
+*)
+
+let 10 = !. (scspe 10);;
+
+(* ---------------------------------------------------------------------- *)
+(* Scope extrusion via mutable state *)
+
+(*
+let extr = let x = ref .<1>. in
+ let _ = .<fun v -> .~(x := .<v>.; .<()>.)>. in
+ !x;;
+
+(* It does type-check ... but printing it produces an error *)
+
+ val extr : int code = .<v_45>.
+
+Failure("The code built at Characters 50-51:\n let _ = .<fun v -> .~(x := .<v>.; .<()>.)>. in\n ^\n is not closed: identifier v_45 bound at Characters 50-51:\n let _ = .<fun v -> .~(x := .<v>.; .<()>.)>. in\n ^\n is free")
+*)
+
+(* Previously:
+ val extr : ('a, int) code = .<v_1>.
+
+ # !. extr ;;
+ Unbound value v_1
+ Exception: Trx.TypeCheckingError.
+*)
+
+(* The run-time error is reported on an attempt to run the code *)
+let true =
+ try !. (let x = ref .<1>. in
+ let _ = .<fun v -> .~(x := .<v>.; .<()>.)>. in
+ !x); false
+ with Failure e -> print_string e; true
+;;
+(*
+Scope extrusion at Characters 75-76:
+ let _ = .<fun v -> .~(x := .<v>.; .<()>.)>. in
+ ^
+ for the identifier v_66 bound at Characters 60-61:
+ let _ = .<fun v -> .~(x := .<v>.; .<()>.)>. in
+ ^
+*)
+
+(* The run-time error is reported on an attempt to splice the code *)
+let true =
+ try let x = ref .<1>. in
+ let _ = .<fun v -> .~(x := .<v>.; .<()>.)>. in
+ .<1 + .~(!x)>.; false (* triggers an error with the message below *)
+ with Failure e -> print_string e; true
+;;
+(*
+Scope extrusion detected at Characters 97-107:
+ .<1 + .~(!x)>.; false (* triggers an error with the message below *)
+ ^^^^^^^^^^
+ for code built at Characters 57-58:
+ let _ = .<fun v -> .~(x := .<v>.; .<()>.)>. in
+ ^
+ for the identifier v_47 bound at Characters 57-58:
+ let _ = .<fun v -> .~(x := .<v>.; .<()>.)>. in
+ ^
+*)
+
+
+(*
+ * In this example, we compute a staged power function while tracking how many
+ * multiplications the generated code performs. This example demonstrates the
+ * utility of our environment-passing translation, in two ways. First, it is
+ * easiest to write this example if we use a side effect such as mutable state
+ * in MetaOCaml, but such an extension (a piece of state of type int) has not
+ * been shown sound except through our translation. Second, we can write this
+ * example in pure MetaOCaml (more awkwardly) using our translation.
+ *
+ * Thanks to Olivier Danvy for suggesting this example.
+ *)
+
+let rec powerc = function
+ | 0 -> (.<fun x -> 1>.,0)
+ | 1 -> (.<fun x -> x>.,1)
+ | n -> let (c,n1) = powerc (pred n) in
+ (.<fun x -> (.~c x) * x>.,succ n1)
+;;
+(*
+ val powerc : int -> (int -> int) code * int = <fun>
+*)
+
+let test = powerc 5;;
+(*
+val test : (int -> int) code * int =
+ (.<
+ fun x_52 ->
+ ((fun x_51 ->
+ ((fun x_50 ->
+ ((fun x_49 -> ((fun x_48 -> x_48) x_49) * x_49) x_50) * x_50)
+ x_51)
+ * x_51) x_52)
+ * x_52>.
+ , 5)
+*)
+
+let 32 = (!. (fst test)) 2;;
+(*
+val testc : int = 32
+*)
+
+let mul x y = .<.<.~.~x * .~.~y>.>.;;
+(*
+val mul : int code code -> int code code -> int code code = <fun>
+*)
+
+let rec powerd = function
+ | 0 -> (.<fun x -> .<1>.>.,0)
+ | 1 -> (.<fun x -> x>.,1)
+ | n -> let (c,n1) = powerd (pred n) in
+ (.<fun x -> .~(mul .<.~c x>. .<x>.)>.,succ n1)
+;;
+(*
+val powerd : int -> (int code -> int code) code * int = <fun>
+*)
+
+let test1 = powerd 5;;
+(*
+val test1 : (int code -> int code) code * int =
+ (.<
+ fun x_57 ->
+ .<
+ (.~(fun x_56 ->
+ .<
+ (.~(fun x_55 ->
+ .<
+ (.~(fun x_54 ->
+ .< (.~(fun x_53 -> x_53) x_54) * (.~(x_54)) >.)
+ x_55)
+ * (.~(x_55)) >.) x_56)
+ * (.~(x_56)) >.) x_57)
+ * (.~(x_57)) >.>.
+ , 5)
+*)
+
+let testd = !. (fst (powerd 5));;
+let testdd = .<fun x -> .~(testd .<x>.)>.;;
+(*
+val testdd : (int -> int) code = .<
+ fun x_63 -> (((x_63 * x_63) * x_63) * x_63) * x_63>.
+*)
+
+(* An attempt to write testd without overt use of multiple levels:
+ no nested brackets.
+*)
+let one = .<1>.;;
+let mul1 x y = .<.~x * .~y>.;;
+let mull x y = .<mul1 .~x .~y>.;;
+
+let rec powerd1 = function
+ | 0 -> (.<fun x -> one>.,0)
+ | 1 -> (.<fun x -> x>.,1)
+ | n -> let (c,n1) = powerd1 (pred n) in
+ (.<fun x -> .~(mull .<.~c x>. .<x>.)>.,succ n1)
+;;
+(*
+val powerd1 : int -> (int code -> int code) code * int = <fun>
+*)
+
+let test11 = powerd1 5;;
+(*
+val test11 : (int code -> int code) code * int =
+ (.<
+ fun x_68 ->
+ ((* cross-stage persistent value (id: mul1) *))
+ ((fun x_67 ->
+ ((* cross-stage persistent value (id: mul1) *))
+ ((fun x_66 ->
+ ((* cross-stage persistent value (id: mul1) *))
+ ((fun x_65 ->
+ ((* cross-stage persistent value (id: mul1) *))
+ ((fun x_64 -> x_64) x_65) x_65) x_66) x_66) x_67)
+ x_67) x_68) x_68>.
+ , 5)
+*)
+
+let testd1 () = !. (fst (powerd1 5));;
+let testdd1 = .<fun x -> .~(testd1 () .<x>.)>.;;
+(*
+val testdd1 : (int -> int) code = .<
+ fun x_69 -> (((x_69 * x_69) * x_69) * x_69) * x_69>.
+*)
+let 32 = (Runcode.run .<fun x -> .~(testd1 () .<x>.)>.) 2;;
+
+
+(* Meta-programming with delimited continuations *)
+(* Writing an efficient specialized version of Gibonacci,
+ without using any fix-point combinators, etc.
+*)
+
+open Printf;;
+
+(* The original Gibonacci *)
+
+let rec gib x y n =
+ if n = 0 then x else
+ if n = 1 then y else
+ gib x y (n-1) + gib x y (n-2)
+;;
+let 8 = gib 1 1 5;;
+
+(* Naively staged Gibonacci, to the statically known value of n *)
+
+let rec gibgen x y n =
+ if n = 0 then x else
+ if n = 1 then y else
+ .<.~(gibgen x y (n-1)) + .~(gibgen x y (n-2))>.
+;;
+(*
+ val gibgen : ('cl, int) code -> ('cl, int) code -> int -> ('cl, int) code
+*)
+let test_gibgen n = .<fun x y -> .~(gibgen .<x>. .<y>. n)>.;;
+(* val test_gibgen : int -> ('a, int -> int -> int) code = <fun> *)
+let test_gibgen5 = test_gibgen 5;;
+(*
+val test_gibgen5 : (int -> int -> int) code = .<
+ fun x_1 y_2 ->
+ (((y_2 + x_1) + y_2) + (y_2 + x_1)) + ((y_2 + x_1) + y_2)>.
+*)
+let 8 = (!. test_gibgen5) 1 1;;
+
+(* Clearly, the naive Gibonacci is inefficient.
+ The specialized code test_gibgen5 shows why:
+ the computation (y_2 + x_1) is repeated thrice within such a short fragment
+*)
+
+(* To improve Gibonacci, we have to add memoization *)
+
+(* First we define the abstract data types of memoization table
+ with integer keys *)
+
+(* For the sake of the closest correspondence with circle-shift.elf,
+ we use pairs to emulate 'a option data type. In the rest of the
+ code, 'a maybe is an abstract data type.
+*)
+module Maybe :
+ sig
+ type 'a maybe
+ val nothing : 'a maybe
+ val just : 'a -> 'a maybe
+ val ifnothing : 'a maybe -> bool
+ val fromjust : 'a maybe -> 'a
+ end = struct
+ type 'a maybe = bool * (unit -> 'a)
+ let nothing = (true, fun () -> failwith "nothing")
+ let just x = (false, fun () -> x)
+ let ifnothing = fst
+ let fromjust x = snd x ()
+end;;
+open Maybe;;
+
+module Memo :
+ sig
+ type 'a memo
+ val empty : 'a memo
+ val lookup : int -> 'a memo -> 'a maybe
+ val ext : 'a memo -> int -> 'a -> 'a memo
+ end = struct
+ (* The following implementation uses functions, for compatibility
+ with circle-shift.elf. The rest of the code does not depend
+ on the implementation and can't even know it.
+ *)
+ type 'a memo = int -> 'a maybe
+ let empty = fun key -> nothing
+ let lookup = fun n table -> table n
+ let ext = fun table n v ->
+ fun key -> if key = n then just v else table key
+end;;
+open Memo;;
+
+(* we can write the standard, textbook memoizer *)
+(* It memoizes the result of the application of function f to the integer n.
+ *)
+
+let new_memo () =
+ let table = ref empty in
+ fun f n ->
+ let r = lookup n !table in
+ if ifnothing r
+ then (* memo table miss *)
+ let v = f n in (* compute the value *)
+ table := ext !table n v; v
+ else fromjust r (* else return the memoized value *)
+;;
+
+
+(* Now we can memoize Gibonacci and obtain an improved version *)
+let gibo x y =
+ let memo = new_memo () in
+ let rec loop n =
+ if n = 0 then x else
+ if n = 1 then y else
+ memo loop (n-1) + memo loop (n-2)
+ in loop
+;;
+
+let 8 = gibo 1 1 5;; (* 8 *)
+let 1346269 = gibo 1 1 30;;
+(* 1346269, without memoization it would've taken a while...*)
+
+(* We may try to stage it, naively *)
+
+let sgibo_naive x y =
+ let memo = new_memo () in
+ let rec loop n =
+ if n = 0 then x else
+ if n = 1 then y else
+ .<.~(memo loop (n-1)) + .~(memo loop (n-2))>.
+ in loop
+;;
+
+let test_sgibo_naive5 =
+ .<fun x y -> .~(sgibo_naive .<x>. .<y>. 5)>.;;
+(*
+val test_sgibo_naive5 : (int -> int -> int) code = .<
+ fun x_3 y_4 ->
+ (((y_4 + x_3) + y_4) + (y_4 + x_3)) + ((y_4 + x_3) + y_4)>.
+*)
+
+(* Alas, the result shows the duplication of computations. The result of
+ loop, in sgibo_naive, is a present-stage value but future-stage
+ computation. We saved effort at the present stage but we saved no
+ computation at the future stage. We need let insertion to save
+ future-stage computations.
+*)
+
+(* But the let-insertion isn't that easy! The naive version *)
+
+let sgibo1_naive x y =
+ let memo = new_memo () in
+ let rec loop n =
+ if n = 0 then x else
+ if n = 1 then y else
+ .<let t1 = .~(memo loop (n-1)) and t2 = .~(memo loop (n-2))
+ in t1 + t2>.
+ in loop
+;;
+
+let test_sgibo1_naive5 =
+ .<fun x y -> .~(sgibo1_naive .<x>. .<y>. 5)>.
+(*
+val test_sgibo1_naive5 : (int -> int -> int) code = .<
+ fun x_105 y_106 ->
+ let t1_113 =
+ let t1_111 =
+ let t1_109 = let t1_107 = y_106 and t2_108 = x_105 in t1_107 + t2_108
+ and t2_110 = y_106 in t1_109 + t2_110
+ and t2_112 = let t1_107 = y_106 and t2_108 = x_105 in t1_107 + t2_108 in
+ t1_111 + t2_112
+ and t2_114 =
+ let t1_109 = let t1_107 = y_106 and t2_108 = x_105 in t1_107 + t2_108
+ and t2_110 = y_106 in t1_109 + t2_110 in
+ t1_113 + t2_114>.
+*)
+
+(* the naive version obviously doesn't do any good: It creates even bigger
+ duplicated computations *)
+
+(* We have to change the memo table implementation. Our memo table should
+ contain only those future-stage computations that are future-stage
+ values. So, we need to do let-insertion after we detected a miss.
+ But for that, we have to re-write everything in CPS. We have to write
+ the memo-table implementation in CPS:
+*)
+
+let new_memo_let_CPS () =
+ let table = ref empty in
+ fun f n k ->
+ let r = lookup n !table in
+ if ifnothing r
+ then (* memo table miss *)
+ f n (* compute the value *)
+ (fun v -> .<let t = .~v in
+ .~(table := ext !table n .<t>.; k .<t>.)>.)
+ else k (fromjust r) (* else return the memoized value *)
+;;
+
+(* but we also must re-write sgibo in CPS! *)
+
+let sgibo_CPS x y =
+ let memo = new_memo_let_CPS () in
+ let rec loop n k =
+ if n = 0 then k x else
+ if n = 1 then k y else
+ memo loop (n-1) (fun r1 ->
+ memo loop (n-2) (fun r2 ->
+ k .<.~r1 + .~r2>.))
+ in loop
+;;
+
+let test_sgibo_CPS5 =
+ .<fun x y -> .~(sgibo_CPS .<x>. .<y>. 5 (fun x ->x))>.;;
+
+(*
+val test_sgibo_CPS5 : (int -> int -> int) code = .<
+ fun x_2 y_3 ->
+ let t_4 = y_3 in
+ let t_5 = x_2 in
+ let t_6 = t_4 + t_5 in
+ let t_7 = t_6 + t_4 in let t_8 = t_7 + t_6 in t_8 + t_7>.
+*)
+let 8 = (!. test_sgibo_CPS5) 1 1;;
+
+(* Now we get the desired result: no duplicate computations.
+ At the cost of changing all of our code, even sgibo, in CPS.
+ Memoization is no longer easy -- it becomes very intrusive.
+*)
+
+(* Not only this approach inconvenient, it is also unsafe.
+ The mutation in maintaining the table in new_memo_let_CPS
+ results in unsafety. We store in the `global' memo table code
+ values like .<t>. -- with variables bound in the scope
+ that is more narrow than the dynamic scope of the table.
+ *)
+
+(* Let's make a simple `pessimization' of sgibo1_CPS. Let's suppose the
+ programmer didn't want to rewrite gib in CPS, and continued to use
+ memoization in `direct style'.
+*)
+
+let sgibo1_bad x y =
+ let memo = new_memo_let_CPS () in
+ let rec loop n =
+ if n = 0 then x else
+ if n = 1 then y else
+ .<.~(memo (fun n k -> k (loop n)) (n-1) (fun x ->x)) +
+ .~(memo (fun n k -> k (loop n)) (n-2) (fun x ->x))>.
+ in loop
+;;
+
+let true =
+ try
+ let test_sgibo1_bad =
+ .<fun x y -> .~(sgibo1_bad .<x>. .<y>. 5)>. in
+ false
+ with Failure e -> print_string e; true
+;;
+
+(* Previously (before version N100) it worked:
+ val test_sgibo1_bad : ('a, int -> int -> int) code =
+ .<fun x_1 ->
+ fun y_2 ->
+ (let t_7 = (t_6 + t_5) in t_7 +
+ let t_6 =
+ (let t_5 = (t_3 + let t_4 = x_1 in t_4) in t_5 + let t_3 = y_2 in t_3) in
+ t_6)>.
+*)
+
+(* Although the result appears efficient -- only four additions --
+ it is incorrect! Please notice how variable t_6 is referenced before
+ it is bound. Attempting to run this code gives
+
+!. test_sgibo1_bad;;
+ Unbound value t_6
+ Exception: Trx.TypeCheckingError.
+*)
+
+(* But now we get a scope extrusion error
+Scope extrusion detected at Characters 133-243:
+ .............................ng e; true;;
+ for code built at Characters 242-243:
+ for the identifier t_131 bound at Characters 242-243:
+*)
+
+(* To rely on MetaOCaml's type soundness, we must not use any side effects
+ in our code generator. We could write our memoizing gib without state,
+ by including state-passing in our continuation-passing, as follows.
+*)
+
+let new_memo_let_CPS_only f n k table =
+ let r = lookup n table in
+ if ifnothing r
+ then
+ f n
+ (fun v table -> .<let t = .~v in
+ .~(k .<t>. (ext table n .<t>.))>.)
+ table
+ else
+ k (fromjust r) table
+;;
+
+let sgibo_CPS_only x y =
+ let memo = new_memo_let_CPS_only in
+ let rec loop n k =
+ if n = 0 then k x else
+ if n = 1 then k y else
+ memo loop (n-1) (fun r1 ->
+ memo loop (n-2) (fun r2 ->
+ k .<.~r1 + .~r2>.))
+ in loop
+;;
+
+let test_sgibo_CPS_only5 =
+ .<fun x y -> .~(sgibo_CPS_only .<x>. .<y>. 5 (fun r table -> r) empty)>.;;
+
+let 8 = (!. test_sgibo_CPS_only5) 1 1;;
+
+Printf.printf "\nAll Done\n";;
diff -Naur ocaml-4.02.1/metalib/test/simple.ml ocaml-ber-n102/metalib/test/simple.ml
--- ocaml-4.02.1/metalib/test/simple.ml 1970-01-01 01:00:00.000000000 +0100
+++ ocaml-ber-n102/metalib/test/simple.ml 2015-01-10 16:27:06.936030975 +0000
@@ -0,0 +1,182 @@
+(* Various simple (one-liner) examples and NON-examples *)
+open Runcode;;
+
+(* Safety of run *)
+
+let tr1 = .<fun x -> .~(!. .<.<1>.>.)>.;;
+(*
+val tr1 : ('a -> int) code = .<fun x_54 -> 1>.
+*)
+let tr1' = .<fun x -> .~(!. .<.<fun x -> x>.>.)>.;;
+(*
+val tr1' : ('a -> 'b -> 'b) code = .<fun x_55 x_56_57 -> x_56_57>.
+*)
+let tr2 = .<fun x -> .~(let x = !. .<1>. in .<x>.)>.;;
+(*
+val tr2 : ('a -> int) code = .<fun x_58 -> 1>.
+*)
+
+let tr3 = .<fun x -> .~(let x = !. .<x>. in .<x>.)>.;;
+
+(*
+Exception:
+Failure
+ "The code built at Characters 16-17:\n let tr3 = .<fun x -> .~(let x = !. .<x>. in .<x>.)>.;;\n ^\n is not closed: identifier x_59 bound at Characters 16-17:\n let tr3 = .<fun x -> .~(let x = !. .<x>. in .<x>.)>.;;\n ^\n is free".
+
+Was:
+ let tr3 = .<fun x -> .~(let x = !. .<x>. in .<x>.)>.;;
+ ^^^^^
+Error: !. error: 'a not generalizable in ('a, 'b) code
+*)
+print_endline "Error was expected";;
+
+.< fun x -> .~ (!. .< x >.) >.;;
+(*
+Exception:
+Failure
+ "The code built at Characters 7-8:\n .< fun x -> .~ (!. .< x >.) >.;;\n ^\n is not closed: identifier x_60 bound at Characters 7-8:\n .< fun x -> .~ (!. .< x >.) >.;;\n ^\n is free".
+
+Was:
+Characters 15-26:
+ .< fun x -> .~ (!..< x >.) >.;;
+ ^^^^^^^^^^^
+Error: !. occurs check error: 'cl occurs in ('cl, ('cl, 'a) code) code
+*)
+print_endline "Error was expected";;
+
+let tr4 = .<fun x -> .~(let x = !. x in .<x>.)>.;;
+(*
+Characters 35-36:
+ let tr4 = .<fun x -> .~(let x = !. x in .<x>.)>.;;
+ ^
+Error: Wrong level: variable bound at level 1 and used at level 0
+*)
+print_endline "Error was expected";;
+
+let tr5 = .<fun x -> !. .<1>.>.;;
+(*
+val tr5 : ('a -> int) code = .<fun x_61 -> Runcode.( !. ) (.< 1 >.)>.
+*)
+let 1 = (!. tr5) true;;
+
+let tr6 = .<fun x -> !. .<x>.>.;;
+(*
+val tr6 : ('a -> 'a) code = .<fun x_62 -> Runcode.( !. ) (.< x_62 >.)>.
+*)
+let 1 = (!. tr6) 1;;
+
+let tr7 = .<fun x -> !. x>.;;
+(*
+val tr7 : ('a code -> 'a) code = .<fun x_63 -> Runcode.( !. ) x_63>.
+
+Was:
+Characters 24-25:
+ let tr7 = .<fun x -> !. x>.;;
+ ^
+Error: !. error: 'a not generalizable in ('a, 'b) code
+print_endline "Error was expected";;
+*)
+let 10 = !. tr7 .<10>.;;
+
+ (* Bizzare CSP *)
+let tr8 = .<fun x -> .~(let y = .<x>. in .<y>.)>.;;
+(*
+Characters 43-44:
+ let tr8 = .<fun x -> .~(let y = .<x>. in .<y>.)>.;;
+ ^
+Warning 22: The CSP value is a closure or too deep to serialize
+val tr8 : ('a -> 'a code) code = .<fun x_121 -> (* CSP y *)>.
+*)
+(* But it cannot be run! *)
+let tr8r = !. tr8;;
+(*
+val tr8r : '_a -> '_a code = <fun>
+
+Was
+Characters 14-17:
+ let tr8r = !. tr8;;
+ ^^^
+Error: !. occurs check error: 'a occurs in ('a, 'b -> ('a, 'b) code) code
+print_endline "Error was expected";;
+*)
+(* And it cannot be run indeed *)
+!. tr8 10;;
+(*
+- : int code = .<x_65>.
+
+Failure("The code built at Characters 16-17:\n is not closed: identifier x_65 bound at Characters 16-17:\n is free")
+*)
+print_endline "Error was expected";;
+
+let tm1 = .<fun x -> .< x >. >.;;
+(*
+val tm1 : ('a -> 'a code) code = .<fun x_66 -> .< x_66 >.>.
+*)
+!. tm1 10;;
+(*
+- : int code = .<(* CSP x_122 *) Obj.magic 10>.
+*)
+let 10 = !. (!. tm1 10);;
+
+(* Generalization *)
+
+let tg1 = !. ((fun x -> .<x>.) (ref []));;
+(*
+val tg1 : '_a list ref = {contents = []}
+ should not be polymorphic!
+*)
+let tg2 = !. .<ref []>.;;
+(*
+val tg2 : '_a list ref = {contents = []}
+ should not be polymorphic!
+*)
+
+(*
+(* First-class polymorphism *)
+
+(* Recall, in runcode.mli:
+
+type 'a cde = {cde : 'c. ('c,'a) code} (* Type of the closed code *)
+
+*)
+
+(* In all previous versions of MetaOCaml, up to BER N004:
+
+# Runcode.run;;
+- : 'a Runcode.cde -> 'a = <fun>
+# {Runcode.cde = .<1>.};;
+- : int Runcode.cde = .<1>.
+# Runcode.run {Runcode.cde = .<1>.};;
+- : int = 1
+# .<{Runcode.cde = .<1>.}>.;;
+- : ('a, int Runcode.cde) code = .<{Runcode.cde = .<1>.}>.
+# !. .<{Runcode.cde = .<1>.}>.;;
+Characters 22-23:
+ !. .<{Runcode.cde = .<1>.}>.;;
+ ^
+Error: This expression has type ('a, int) code
+ but an expression was expected of type ('b, int) code
+
+Exception: Trx.TypeCheckingError.
+*)
+
+(* Now *)
+let tfc1 = {Runcode.cde = .<1>.};;
+(* - : int Runcode.cde = .<1>. *)
+let 1 = Runcode.run {Runcode.cde = .<1>.};;
+
+let tfc2 = .<{Runcode.cde = .<1>.}>.;;
+(*
+- : ('cl, int Runcode.cde) code = .<{Runcode.cde = .<1>.}>.
+*)
+let tfc3 = !. .<{Runcode.cde = .<1>.}>.;;
+(* - : int Runcode.cde = .<1>. *)
+let tfc4 = {Runcode.cde= .<{Runcode.cde = .<1>.}>.};;
+(* - : int Runcode.cde Runcode.cde = .<{Runcode.cde = .<1>.}>. *)
+let tfc5 = Runcode.run {Runcode.cde= .<{Runcode.cde = .<1>.}>.};;
+(* - : int Runcode.cde = .<1>. *)
+let 1 = Runcode.run (Runcode.run {Runcode.cde= .<{Runcode.cde = .<1>.}>.});;
+(* - : int = 1 *)
+*)
+
+Printf.printf "\nAll Done\n";;
diff -Naur ocaml-4.02.1/metalib/test/simple_true.ml ocaml-ber-n102/metalib/test/simple_true.ml
--- ocaml-4.02.1/metalib/test/simple_true.ml 1970-01-01 01:00:00.000000000 +0100
+++ ocaml-ber-n102/metalib/test/simple_true.ml 2015-01-10 16:27:06.936030975 +0000
@@ -0,0 +1,137 @@
+(* Various simple tests, all should pass. Whenever an error is discovered,
+ please add here.
+*)
+open Runcode;;
+
+(* From Problems.txt Wed Oct 2 08:39:04 BST 2002
+ Occurrences of a csp value share the same instantiated type
+*)
+
+let f1 x = x;; (* polymophic *)
+let t1 = .<(f1 1, f1 true)>.;;
+(*
+val t1 : (int * bool) code = .<
+ ((((* cross-stage persistent value (id: f1) *)) 1),
+ (((* cross-stage persistent value (id: f1) *)) true))>.
+*)
+let (1,true) = !. t1;;
+
+(* From Problems.txt Thu Oct 24 09:55:36 BST 2002
+ CSP at level n+2 gives Segmentation fault
+*)
+(* use f1 above *)
+let t2 = .<(.<f1 1>., .<f1 true>.)>.;;
+(*
+val t2 : (int code * bool code) code = .<
+ ((.< ((* cross-stage persistent value (id: f1) *)) 1 >.),
+ (.< ((* cross-stage persistent value (id: f1) *)) true >.))>.
+*)
+let 1 = !. (fst (!. t2));;
+let true = !. (snd (!. t2));;
+
+(* From Problems.txt Mon Nov 25 10:10:32 GMT 2002
+ CSP of array ops gives internal errors
+*)
+
+let t3 = .<Array.get [|1|] 0>.;;
+(*
+val t3 : int code = .<[|1|].(0)>.
+*)
+let 1 = !. t3;;
+
+(* From Problems.txt Tue Jan 20 12:18:00 GMTST 2004
+ typechecker broken for csp ids, e.g. we get the wrong type
+ We get the incorrect typing (inner and outer code forced to be both 'a)
+ # .<fun x -> .<x>.>.;;
+*)
+
+let t4 = .<fun x -> .<x>.>.;;
+(*
+val t4 : ('a -> 'a code) code = .<fun x_67 -> .< x_67 >.>.
+*)
+let true = !. ((!. t4) true);;
+
+(* From Problems.txt Mon Jan 10 18:51:21 GMTST 2005
+ CSP constants in Pervasives (and similar) are type checked only once for
+ a given occurrence.
+ # let f x = .< ref .~ x>.
+ in (!. (f .<3>.), !. (f .<1.3>.));;
+ This expression has type int but is here used with type float
+*)
+
+let t5 =
+ let f x = .< ref .~ x>.
+ in (!. (f .<3>.), !. (f .<1.3>.));;
+
+(*
+val t5 : int ref * float ref = ({contents = 3}, {contents = 1.3})
+*)
+
+(* From Problems.txt Tue Jan 18 14:08:52 GMTST 2005
+ type aliases are not handled correctly in code, example:
+ # type a = int;;
+ # let f (x:a) = 1;;
+ # !. .<f 1>.;;
+*)
+type a = int;;
+let 1 =
+ let f (x:a) = 1 in
+ !. .<f 1>.;;
+
+(* From Problems.txt Oct 3, 2006 Printing of records in brackets *)
+
+let t7 =
+ let open Complex in
+ .<let x = {re=1.0; im=2.0} in
+ let y = {x with re = 2.0} in
+ y>.
+ ;;
+
+(*
+val t7 : Complex.t code = .<
+ let x_14 = { Complex.re = 1.0; Complex.im = 2.0 } in
+ let y_15 = { x_14 with Complex.re = 2.0 } in y_15>.
+*)
+
+let {Complex.re=2.0; im=2.0} = !. t7;;
+
+(* First-class polymorphism *)
+(*
+let tfc1 = {Runcode.cde = .<1>.};;
+(* - : int Runcode.cde = .<1>. *)
+let 1 = Runcode.run {Runcode.cde = .<1>.};;
+
+let tfc2 = .<{Runcode.cde = .<1>.}>.;;
+(*
+- : ('cl, int Runcode.cde) code = .<{Runcode.cde = .<1>.}>.
+*)
+let tfc3 = !. .<{Runcode.cde = .<1>.}>.;;
+(* - : int Runcode.cde = .<1>. *)
+let tfc4 = {Runcode.cde= .<{Runcode.cde = .<1>.}>.};;
+(* - : int Runcode.cde Runcode.cde = .<{Runcode.cde = .<1>.}>. *)
+let tfc5 = Runcode.run {Runcode.cde= .<{Runcode.cde = .<1>.}>.};;
+(* - : int Runcode.cde = .<1>. *)
+let 1 = Runcode.run (Runcode.run {Runcode.cde= .<{Runcode.cde = .<1>.}>.});;
+(* - : int = 1 *)
+*)
+
+(* complex runs *)
+let tr1 = .<fun x -> .~(!. .<.<1>.>.)>.;;
+let 1 = (!. tr1) 42;;
+(*
+val tr1 : ('a -> int) code = .<fun x_17 -> 1>.
+*)
+
+let tr1' = .<fun x -> .~(!. .<.<fun x -> x>.>.)>.;;
+(*
+val tr1' : ('a -> 'b -> 'b) code = .<fun x_70 x_71_72 -> x_71_72>.
+*)
+let 2 = (!. tr1') 1 2;;
+
+let tr2 = .<fun x -> .~(let x = !. .<1>. in .<x>.)>.;;
+(*
+val tr2 : ('a -> int) code = .<fun x_73 -> 1>.
+*)
+let 1 = (!. tr2) 42;;
+
+Printf.printf "\nAll Done\n";;
diff -Naur ocaml-4.02.1/metalib/test/t4.ml ocaml-ber-n102/metalib/test/t4.ml
--- ocaml-4.02.1/metalib/test/t4.ml 1970-01-01 01:00:00.000000000 +0100
+++ ocaml-ber-n102/metalib/test/t4.ml 2015-01-10 16:27:06.936030975 +0000
@@ -0,0 +1,110 @@
+
+(* Author: Walid Taha and Cristiano Calcagno
+ Date: Fri Aug 31 03:03:11 EDT 2001 *)
+
+open Runcode;;
+open T4types;;
+
+let unJ(J i) = i
+let unF(F f) = f
+
+let term0 = A(L("x",V"x"),I 7)
+
+let term1 = A(R ("f","n", C(V "n",I 42,A (V "f",D (V "n")))),I 1000000)
+
+exception Yiikes
+;;
+
+let env0 = fun x -> raise Yiikes;;
+
+let ext env x v = fun y -> if x=y then v else env y
+
+let rec eval e env =
+match e with
+ I i -> J i
+| V s -> env s
+| A (e1,e2) -> (unF(eval e1 env)) (eval e2 env)
+| L (x,e) -> F (fun v -> eval e (ext env x v))
+| D e -> J ((unJ (eval e env))-1)
+| C (e1,e2,e3) -> if (unJ(eval e1 env))=0
+ then (eval e2 env)
+ else (eval e3 env)
+| R (f,x,e) -> F (let rec ff xx = eval e (ext (ext env x xx)
+ f (F ff))
+ in ff)
+;;
+
+let J 42 = eval term1 env0;; (* Unstaged *)
+
+let rec eval' e env =
+match e with
+ I i -> .<J i>.
+| V s -> env s
+| A (e1,e2) -> .<(unF .~(eval' e1 env)) (.~(eval' e2 env))>.
+| L (x,e) -> .<F (fun v -> .~(eval' e (ext env x .<v>.)))>.
+| D e -> .<J (unJ .~(eval' e env) - 1)>.
+| C (e1,e2,e3) -> .< if (unJ .~(eval' e1 env)) = 0
+ then .~(eval' e2 env)
+ else .~(eval' e3 env) >.
+| R (f,x,e) ->
+ .<F (let rec ff xx = .~(eval' e (ext (ext env x .<xx>.) f .<F ff>.)) in ff)>.
+;;
+
+let stage1Running = eval' term1 env0;;
+
+(*
+val stage1Running : ('a, dom) code =
+ .<((((* cross-stage persistent value (as id: unF) *))
+ (F
+ (let rec ff_1 =
+ fun xx_2 ->
+ if ((((* cross-stage persistent value (as id: unJ) *)) xx_2) = 0) then
+ (J (42))
+ else
+ ((((* cross-stage persistent value (as id: unF) *)) (F (ff_1)))
+ (J
+ ((((* cross-stage persistent value (as id: unJ) *)) xx_2) - 1))) in
+ ff_1))) (J (1000000)))>.
+
+*)
+let compiling = !. .<fun () -> .~ stage1Running>.;;
+
+let J 42 = compiling ();;
+
+let unJ' = .<fun (J i) -> i>.
+let unF' = .<fun (F f) -> f>.
+
+let rec eval'' e env =
+match e with
+ I i -> .<J i>.
+| V s -> env s
+| A (e1,e2) -> .<.~unF' .~(eval'' e1 env) .~(eval'' e2 env)>.
+| L (x,e) -> .<F (fun v -> .~(eval'' e (ext env x .<v>.)))>.
+| D e -> .<J (.~unJ' .~(eval'' e env) - 1)>.
+| C (e1,e2,e3) -> .<if .~unJ' .~(eval'' e1 env) = 0
+ then .~(eval'' e2 env)
+ else .~(eval'' e3 env)>.
+| R (f,x,e) ->
+ .<F (let rec ff xx = .~(eval'' e (ext (ext env x .<xx>.) f (.<F ff>.))) in ff)>.
+;;
+
+let stage1Running' = eval'' term1 env0;;
+
+(*
+val stage1Running' : ('a, dom) code =
+ .<((fun F (f_2) -> f_2)
+ (F
+ (let rec ff_1 =
+ fun xx_2 ->
+ if (((fun J (i_1) -> i_1) xx_2) = 0) then (J (42))
+ else
+ ((fun F (f_2) -> f_2) (F (ff_1))
+ (J (((fun J (i_1) -> i_1) xx_2) - 1))) in
+ ff_1)) (J (1000000)))>.
+*)
+
+let compiling' = !. .<fun () -> .~ stage1Running'>.;;
+
+let J 42 = (compiling' ());;
+
+Printf.printf "\n4.ml Done\n";;
diff -Naur ocaml-4.02.1/metalib/test/t4types.mli ocaml-ber-n102/metalib/test/t4types.mli
--- ocaml-4.02.1/metalib/test/t4types.mli 1970-01-01 01:00:00.000000000 +0100
+++ ocaml-ber-n102/metalib/test/t4types.mli 2015-01-10 16:27:06.936030975 +0000
@@ -0,0 +1,17 @@
+(* Data type declarations for the staged eval example by
+ Walid Taha and Cristiano Calcagno
+
+In MetaOCaml N100, all data types used within brackets must be
+in separate .ml or .mli files
+*)
+
+type exp = I of int
+ | V of string
+ | A of exp * exp
+ | L of string * exp
+ | D of exp
+ | C of exp * exp * exp
+ | R of string * string * exp
+
+type dom = J of int
+ | F of (dom -> dom)
diff -Naur ocaml-4.02.1/metalib/test/test20.ml ocaml-ber-n102/metalib/test/test20.ml
--- ocaml-4.02.1/metalib/test/test20.ml 1970-01-01 01:00:00.000000000 +0100
+++ ocaml-ber-n102/metalib/test/test20.ml 2015-01-10 16:27:06.936030975 +0000
@@ -0,0 +1,20 @@
+open Bool2
+
+type ('a,'b,'c) unary = {
+ unow : 'b -> 'c ;
+ ulater : ('a,'b) code -> ('a, 'c) code
+}
+
+module type SET =
+sig
+ type n
+ val to_string : ('a, n, string) unary
+end
+
+module E2 (N : SET) = struct
+ let to_str p = match p with
+ | Now (x,y) -> Now ((N.to_string.unow x) ^ (N.to_string.unow y))
+ | Later p -> Later (.< let (x, y) = .~p in
+ .~(N.to_string.ulater .<x>.) ^
+ .~(N.to_string.ulater .<y>.) >. )
+end
diff -Naur ocaml-4.02.1/metalib/test/test21.ml ocaml-ber-n102/metalib/test/test21.ml
--- ocaml-4.02.1/metalib/test/test21.ml 1970-01-01 01:00:00.000000000 +0100
+++ ocaml-ber-n102/metalib/test/test21.ml 2015-01-10 16:27:06.936030975 +0000
@@ -0,0 +1,5 @@
+(* this generates an error in BER-meta but not in meta-309-alpha-030 *)
+module Bool = struct module C = struct end end
+
+let h = .<"" ^ "">.
+
diff -Naur ocaml-4.02.1/metalib/test/test_levels.ml ocaml-ber-n102/metalib/test/test_levels.ml
--- ocaml-4.02.1/metalib/test/test_levels.ml 1970-01-01 01:00:00.000000000 +0100
+++ ocaml-ber-n102/metalib/test/test_levels.ml 2015-01-10 16:27:06.936030975 +0000
@@ -0,0 +1,43 @@
+(* Test for the maintenance of generalization levels.
+ The test submitted by Jun Inoue, Apr 24, 2014
+
+ Previously, when loaded in metaocaml top level,
+ it triggered assertion false in
+ typing/typecore.ml, in the local function lower_args
+ defined when type checking Pexp_apply.
+*)
+
+let cde_eq c1 = ()
+
+type 'a cde = Cde of 'a
+
+let get_cde x =
+ match x with
+ | Cde c -> ()
+
+type 'a glist = Cons of 'a
+
+
+(* If we move glist_eq below the let _ = ... part, we get:
+
+ | Cons x -> true
+ ^^^^^^
+Error: This pattern matches values of type 'a glist
+ but a pattern was expected which matches values of type 'a glist
+ The type constructor glist would escape its scope
+
+ *)
+let glist_eq x =
+ match x with
+ | Cons x -> ()
+
+(* Invoking Runcode.run seems to be essential. Defining and using
+ let myrun : 'a code -> 'a = fun x -> failwith ""
+ doesn't provoke the bug.
+ *)
+let _ = Runcode.run .<()>.;;
+
+(* This has to use glist_eq. Using get_cde instead won't cut it. *)
+let sumF env = glist_eq env;;
+
+Printf.printf "\nAll Done\n";;
diff -Naur ocaml-4.02.1/metalib/test/test_path_a.ml ocaml-ber-n102/metalib/test/test_path_a.ml
--- ocaml-4.02.1/metalib/test/test_path_a.ml 1970-01-01 01:00:00.000000000 +0100
+++ ocaml-ber-n102/metalib/test/test_path_a.ml 2015-01-10 16:27:06.936030975 +0000
@@ -0,0 +1,3 @@
+(* Testing of setting of .cmo path
+ See test_path.ml for explanation *)
+type t = A
diff -Naur ocaml-4.02.1/metalib/test/test_path.ml ocaml-ber-n102/metalib/test/test_path.ml
--- ocaml-4.02.1/metalib/test/test_path.ml 1970-01-01 01:00:00.000000000 +0100
+++ ocaml-ber-n102/metalib/test/test_path.ml 2015-01-10 16:27:06.936030975 +0000
@@ -0,0 +1,34 @@
+(* Testing of setting of .cmo path *)
+(* The need for setting the path was pointed out by Nicolas Ojeda Bar.
+ The following is his simple example.
+ We assume that test_path_a.cmo and test_path_a.cmi are moved
+ to the tmp/
+
+ First of all, to even compile this file we need to pass the flag
+ -I /tmp to ocamlc or metaocamlc. Typechecker needs to know where to
+ find test_path.cmi. This is needed for compilation, before any code
+ is run.
+*)
+
+
+(* Now, if the code is type-checked and the executable is made, to run
+ it we still have to specify where to find test_path.cmi amd .cmo files.
+ Otherwise, we get the following *run-time* error.
+
+Error: Unbound module Test_path_a
+
+Fatal error: exception Failure("Error type-checking generated code: scope extrusion?")
+*)
+
+(*
+let _ =
+ .< Test_path_a.A >.
+*)
+
+(* This is needed to run the generated code *)
+let () = Runcode.add_search_path "/tmp"
+
+let _ =
+ Runcode.run .< Test_path_a.A >.
+
+let _ = Printf.printf "All Done\n"
diff -Naur ocaml-4.02.1/metalib/test/trivial.ml ocaml-ber-n102/metalib/test/trivial.ml
--- ocaml-4.02.1/metalib/test/trivial.ml 1970-01-01 01:00:00.000000000 +0100
+++ ocaml-ber-n102/metalib/test/trivial.ml 2015-01-10 16:27:06.936030975 +0000
@@ -0,0 +1,1179 @@
+(* Trivial tests of MetaOCaml, which are also regression tests *)
+open Runcode;;
+
+3+2;;
+(* - : int = 5 *)
+let rec fact = function | 0 -> 1 | n -> n * fact (n-1);;
+(* val fact : int -> int = <fun> *)
+let 120 = fact 5;;
+
+.<1>.;;
+(* - : int code = .<1>. *)
+.<"aaa">.;;
+(* - : string code = .<"aaa">. *)
+let 1 = !. .<1>.;;
+(* - : int = 1 *)
+
+close_code .<1>.;;
+(* - : int Runcode.closed_code = .<1>. *)
+
+(* Problem with special treatment of top-level identifiers by the
+ type checker
+*)
+List.rev;;
+(* - : 'a list -> 'a list = <fun> *)
+
+(* Also check the generalization *)
+.<List.rev>.;;
+(* - : ('a list -> 'a list) code = .<List.rev>. *)
+
+.<fun x -> .~(let y = x in y)>.;;
+(*
+Characters 22-23:
+ .<fun x -> .~(let y = x in y)>.;;
+ ^
+Wrong level: variable bound at level 1 and used at level 0
+*)
+print_endline "Error was expected";;
+
+.<fun x -> 1 + .~(.<true>.)>.;;
+(*
+Characters 17-27:
+ .<fun x -> 1 + .~(.<true>.)>.;;
+ ^^^^^^^^^^
+Error: This expression has type bool but an expression was expected of type
+ int
+*)
+print_endline "Error was expected";;
+
+
+(* CSP *)
+
+let x = 1 in .<x>.;;
+(*
+- : int code = .<1>.
+*)
+let x = 1.0 in .<x>.;;
+(*
+- : float code = .<1.>.
+*)
+let x = true in .<x>.;;
+(*
+- : bool code = .<true>.
+*)
+let x = "aaa" in .<x>.;;
+(*
+- : string code = .<"aaa">.
+*)
+let x = 'a' in .<x>.;;
+(*
+- : char code = .<'a'>.
+*)
+let x = ['a'] in .<x>.;;
+(*
+- : char list code = .<(* CSP x *)>.
+*)
+
+let l x = .<x>.;; (* polymorphic *)
+(* val l : 'a -> 'a code = <fun> *)
+l 1;;
+(*
+- : int code = .<(* CSP x *) Obj.magic 1>.
+*)
+let 1 = !. (l 1);;
+l 1.0;; (* better printing in N100 *)
+(*
+- : float code = .<1.>.
+*)
+let 1.0 = !. (l 1.0);;
+l [];; (* serializable code in N102 *)
+(*
+- : 'a list code = .<(* CSP x *) Obj.magic 0>.
+*)
+let [] = !. (l []);;
+
+l (fun x -> x + 1);;
+(*
+Characters 12-13:
+ l (fun x -> x + 1);;
+ ^
+Warning 22: The CSP value is a closure or too deep to serialize
+- : (int -> int) code = .<(* CSP x *)>.
+*)
+
+.<List.rev>.;;
+(*
+- : ('a list -> 'a list) code = .<List.rev>.
+*)
+
+.<Array.get>.;;
+(*
+- : ('a array -> int -> 'a) code = .<Array.get>.
+*)
+.<(+)>.;;
+(*
+- : (int -> int -> int) code = .<Pervasives.(+)>.
+*)
+
+
+let x = true in .<assert x>.;;
+(*
+- : unit code = .<assert true>.
+*)
+!. .<assert (2>1)>.;;
+
+(* Applications and labels *)
+.<succ 1>.;;
+(*
+- : int code = .<Pervasives.succ 1>.
+*)
+
+let 2 = !. .<succ 1>.;;
+
+.<1 + 2>.;;
+(*
+- : int code = .<(1 + 2)>.
+*)
+let 3 = !. .<(1 + 2)>.;;
+
+.<String.length "abc">.;;
+(*
+- : int code = .<String.length "abc">.
+*)
+let 3 =
+ !. .<String.length "abc">.;;
+
+.<StringLabels.sub ~pos:1 ~len:2 "abc">.;;
+(*
+- : string code = .<(StringLabels.sub "abc" ~pos:1 ~len:2>.
+*)
+let "bc" =
+ !. .<StringLabels.sub ~pos:1 ~len:2 "abc">.;;
+
+.<StringLabels.sub ~len:2 ~pos:1 "abc">.;;
+(*
+- : string code = .<(StringLabels.sub "abc" ~pos:1 ~len:2>.
+*)
+let "bc" =
+ !. .<StringLabels.sub ~len:2 ~pos:1 "abc">.;;
+
+(* Nested brackets and escapes and run *)
+.<.<1>.>.;;
+(* - : int code code = .<.< 1 >.>. *)
+!. .<.<1>.>.;;
+(* - : int code = .<1>. *)
+let 1 = !. !. .<.<1>.>.;;
+(* - : int = 1 *)
+.<!. .<1>.>.;;
+(*
+- : int code = .<Runcode.(!.) (.< 1 >.)>.
+*)
+let 1 = !. .<!. .<1>.>.;;
+.<1 + .~(let x = 2 in .<x>.)>.;;
+(*
+- : int code = .<1 + 2>.
+*)
+let x = .< 2 + 4 >. in .< .~ x + .~ x >. ;;
+(*
+- : int code = .<(2 + 4) + (2 + 4)>.
+*)
+let 12 = !. (let x = .< 2 + 4 >. in .< .~ x + .~ x >. );;
+
+.<1 + .~(let x = 2 in .<.<x>.>.)>.;;
+(*
+ .<1 + .~(let x = 2 in .<.<x>.>.)>.;;
+ ^
+Error: This expression has type 'a code
+ but an expression was expected of type int
+*)
+print_endline "Error was expected";;
+.<1 + !. .~(let x = 2 in .<.<x>.>.)>.;;
+(*
+- : int code = .<1 + (Runcode.(!.) .< 2 >.)>.
+*)
+let 3 = !. .<1 + !. .~(let x = 2 in .<.<x>.>.)>.;;
+!. .<1 + .~ (.~(let x = 2 in .<.<x>.>.))>.;;
+(*
+Characters 12-40:
+ !. .<1 + .~ (.~(let x = 2 in .<.<x>.>.))>.;;
+ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: Wrong level: escape at level 0
+*)
+print_endline "Error was expected";;
+
+.<.<.~(.<1>.)>.>.;;
+(*
+- : int code code = .<.< .~(.< 1 >.) >.>.
+- : ('cl, ('cl0, int) code) code = .<.<.~(.<1>.)>.>.
+*)
+!. .<.<.~(.<1>.)>.>.;;
+(*
+- : int code = .<1>.
+*)
+let 1 = !. !. .<.<.~(.<1>.)>.>.;;
+
+.<.<.~.~(.<.<1>.>.)>.>.;;
+(*
+- : int code code = .<.< .~(.< 1 >.) >.>.
+- : ('cl, ('cl0, int) code) code = .<.<.~(.<1>.)>.>.
+*)
+let 1 = !. !. .<.<.~.~(.<.<1>.>.)>.>.;;
+
+(* Nested brackets and escapes on the same identifier *)
+let x = .<1>. in .<.~x>.;;
+(*
+- : int code = .<1>.
+*)
+let 1 = !. (let x = .<1>. in .<.~x>.);;
+
+let x = .<1>. in .<.~.<x>.>.;;
+(*
+- : int code code = .<(* CSP x *)>.
+*)
+!. (let x = .<1>. in .<.~.<x>.>.);;
+(*
+- : int code = .<1>.
+*)
+let 1 = !. !. (let x = .<1>. in .<.~.<x>.>.);;
+
+let x = .<1>. in .<.<.~x>.>.;;
+(*
+- : int code code = .<.< .~((* CSP x *)) >.>.
+*)
+let 1 = !. !. (let x = .<1>. in .<.<.~x>.>.);;
+
+.<.<.~.<List.rev>.>.>.;;
+(*
+- : ('a list -> 'a list) code code = .<.< .~(.< List.rev >.) >.>.
+*)
+!. .<.<.~.<List.rev>.>.>.;;
+(*
+- : ('_a list -> '_a list) code = .<List.rev>.
+*)
+let [3;2;1] = !. !. .<.<.~.<List.rev>.>.>. [1;2;3];;
+
+(* we use a sequence internally to represent brackets and escapes
+ in a Typedtree
+*)
+.<.<begin assert true; 1 end>.>.;;
+(*
+- : int code code = .<.< assert true; 1 >.>.
+*)
+let 1 = !. !. .<.<begin assert true; 1 end>.>.;;
+
+.<.~(.<begin assert true; 1 end>.)>.;;
+(*
+- : int code = .<assert true; 1>.
+*)
+let x = .<begin assert true; 1 end>. in .<.~x>.;;
+(*
+- : int code = .<assert true; 1>.
+*)
+let x = .<begin assert true; 1 end>. in .<.~(assert true; x)>.;;
+(*
+- : int code = .<assert true; 1>.
+*)
+let 1 =
+ let x = .<begin assert true; 1 end>. in !. .<.~(assert true; x)>.;;
+
+let x = .<begin assert true; 1 end>. in .<.~(ignore(!. x); x)>.;;
+(*
+- : int code = .<assert true; 1>.
+*)
+
+
+(* Lazy *)
+.<lazy 1>.;;
+(*
+- : int lazy_t code = .<lazy 1>.
+*)
+let 1 = Lazy.force (!. .<lazy 1>.);;
+
+(* Tuples *)
+.<(1,"abc")>.;;
+(*
+- : (int * string) code = .<(1, "abc")>.
+*)
+.<(1,"abc",'d')>.;;
+(*
+- : (int * string * char) code = .<(1, "abc", 'd')>.
+*)
+let "abc" =
+ match !. .<(1,"abc",'d')>. with (_,x,_) -> x;;
+
+(* Arrays *)
+.<[||]>.;;
+(*
+- : 'a array code = .<[||]>.
+*)
+let x = .<1+2>. in .<[|.~x;.~x|]>.;;
+(*
+- : int array code = .<[|(1 + 2);(1 + 2)|]>.
+*)
+
+(* Constructors and enforcing externality *)
+.<raise Not_found>.;;
+(*
+- : 'a code = .<(raise (Not_found)>.
+*)
+.<raise (Scan_failure "")>.;;
+(*
+Characters 8-25:
+ .<raise (Scan_failure "")>.;;
+ ^^^^^^^^^^^^^^^^^
+Error: Unbound constructor Scan_failure
+*)
+print_endline "Error was expected";;
+.<raise (Scanf.Scan_failure "")>.;;
+(*
+- : 'a code = .<(raise (Scanf.Scan_failure (""))>.
+*)
+open Scanf;;
+.<raise (Scan_failure "")>.;;
+(*
+- : 'a code = .<Pervasives.raise (Scanf.Scan_failure "")>.
+*)
+!. .<raise (Scan_failure "")>.;;
+(*
+Exception: Scanf.Scan_failure "".
+*)
+print_endline "Exception was expected";;
+
+
+.<true>.;;
+(*
+- : bool code = .<true>.
+*)
+.<Some 1>.;;
+(*
+- : int option code = .<Some 1>.
+*)
+.<Some [1]>.;;
+(*
+- : int list option code = .<Some [1]>.
+*)
+let Some [1] = !. .<Some [1]>.;;
+.<None>.;;
+(*
+- : 'a option code = .<None>.
+*)
+let None = !. .<None>.;;
+
+.<Genlex.Int 1>.;;
+(*
+- : Genlex.token code = .<Genlex.Int 1>.
+*)
+open Genlex;;
+.<Int 1>.;;
+(*
+- : Genlex.token code = .<Genlex.Int 1>.
+*)
+let Int 1 = !. .<Int 1>.;;
+
+module Foo = struct exception E end;;
+.<raise Foo.E>.;;
+(*
+Characters 8-13:
+ .<raise Foo.E>.;;
+ ^^^^^
+Exception (extension) Foo.E cannot be used within brackets. Put into a separate file.
+*)
+print_endline "Error was expected";;
+
+type foo = Bar;;
+.<Bar>.;;
+(*
+Characters 2-5:
+ .<Bar>.;;
+ ^^^
+Unqualified constructor Bar cannot be used within brackets. Put into a separate file.
+*)
+print_endline "Error was expected";;
+
+module Foo = struct type foo = Bar end;;
+.<Foo.Bar>.;;
+(*
+Characters 2-9:
+ .<Foo.Bar>.;;
+ ^^^^^^^
+Constructor Bar cannot be used within brackets. Put into a separate file.
+*)
+print_endline "Error was expected";;
+
+(* Records *)
+
+.<{Complex.re = 1.0; im = 2.0}>.;;
+(*
+- : Complex.t code = .<{ Complex.re = 1.0; Complex.im = 2.0 }>.
+*)
+let {Complex.re = 1.; Complex.im = -2.} =
+ Complex.conj (!. .<{Complex.re = 1.0; im = 2.0}>.);;
+let x = {Complex.re = 1.0; im = 2.0} in .<x.re>.;;
+(*
+Characters 44-46:
+ let x = {Complex.re = 1.0; im = 2.0} in .<x.re>.;;
+ ^^
+Warning 40: re was selected from type Complex.t.
+It is not visible in the current scope, and will not
+be selected if the type becomes unknown.
+- : float code = .<(* CSP x *).Complex.re>.
+*)
+
+let x = {Complex.re = 1.0; im = 2.0} in .<x.Complex.re>.;;
+(*
+- : float code =
+.<((* cross-stage persistent value (as id: x) *)).Complex.re>.
+*)
+let 1.0 = !.(let x = {Complex.re = 1.0; im = 2.0} in .<x.Complex.re>.);;
+let x = ref 1 in .<x.contents>.;; (* Pervasive record *)
+(*
+- : int code = .<(* CSP x *).Pervasives.contents>.
+*)
+let 1 = !.(let x = ref 1 in .<x.contents>.);;
+let x = ref 1 in .<x.contents <- 2>.;;
+(*
+- : unit code =
+.<((* cross-stage persistent value (as id: x) *)).contents <- 2>.
+*)
+let x = ref 1 in (!. .<x.contents <- 2>.); x;;
+(* - : int ref = {contents = 2} *)
+
+open Complex;;
+.<{re = 1.0; im = 2.0}>.;;
+(*
+- : Complex.t code = .<{Complex.re = 1.0; Complex.im = 2.0}>.
+*)
+let 5.0 = norm (!. .<{re = 3.0; im = 4.0}>.);;
+let x = {re = 1.0; im = 2.0} in .<x.re>.;;
+(*
+- : float code =
+.<((* cross-stage persistent value (as id: x) *)).Complex.re>.
+*)
+let 1.0 = !.(let x = {re = 1.0; im = 2.0} in .<x.re>.);;
+
+type foo = {fool : int};;
+.<{fool = 1}>.;;
+(*
+Characters 3-7:
+ .<{fool = 1}>.;;
+ ^^^^
+Unqualified label fool cannot be used within brackets. Put into a separate file.
+*)
+print_endline "Error was expected";;
+
+(* Conditional *)
+
+.<if true then 1 else 2>.;;
+(* - : int code = .<if true then 1 else 2>. *)
+.<if Some 1 = None then print_string "weird">.;;
+(*
+- : unit code = .<if (Some 1) = None then Pervasives.print_string "weird">.
+*)
+let () = !. .<if Some 1 = None then print_string "weird">.;;
+
+(* Polymorphic variants *)
+.<`Foo>.;;
+(*
+- : [> `Foo ] code = .<`Foo>.
+*)
+.<`Bar 1>.;;
+(*
+- : [> `Bar of int ] code = .<`Bar 1>.
+*)
+let 1 = match !. .<`Bar 1>. with `Bar x -> x ;;
+
+(* Some support for modules *)
+let f = fun x -> .<x # foo>.;;
+(*
+val f : < foo : 'a; .. > -> 'a code = <fun>
+*)
+let x = object method foo = 1 end;;
+(*
+val x : < foo : int > = <obj>
+*)
+f x;;
+(*
+- : int code = .<(* CSP x *)#foo>.
+*)
+let 1 = !. (f x);;
+
+(* Local open *)
+.<Complex.(norm {re=3.0; im = 4.0})>.;;
+(*
+- : float code = .<Complex.norm { Complex.re = 3.0; Complex.im = 4.0 }>.
+*)
+
+let 5.0 = !. .<Complex.(norm {re=3.0; im = 4.0})>.;;
+
+.<let open Complex in norm {re=4.0; im = 3.0}>.;;
+(*
+- : float code = .<Complex.norm { Complex.re = 4.0; Complex.im = 3.0 }>.
+*)
+
+let 5.0 = !. .<let open Complex in norm {re=4.0; im = 3.0}>.;;
+
+(* For-loop *)
+
+.<for i=1 to 5 do Printf.printf "ok %d %d\n" i (i+1) done>.;;
+(*
+- : unit code = .<
+for i_1 = 1 to 5 do Printf.printf "ok %d %d\n" i_1 (i_1 + 1) done>.
+*)
+!. .<for i=1 to 5 do Printf.printf "ok %d %d\n" i (i+1) done>.;;
+(*
+ok 1 2
+ok 2 3
+ok 3 4
+ok 4 5
+ok 5 6
+*)
+
+.<for i=5 downto 1 do Printf.printf "ok %d %d\n" i (i+1) done>.;;
+(*
+- : unit code = .<
+for i_3 = 5 downto 1 do Printf.printf "ok %d %d\n" i_3 (i_3 + 1) done>.
+*)
+!. .<for i=5 downto 1 do Printf.printf "ok %d %d\n" i (i+1) done>.;;
+(*
+ok 5 6
+ok 4 5
+ok 3 4
+ok 2 3
+ok 1 2
+*)
+
+.<for i=1 to 2 do for j=1 to 3 do Printf.printf "ok %d %d\n" i j done done>.;;
+(*
+- : unit code = .<
+for i_5 = 1 to 2 do
+ for j_6 = 1 to 3 do Printf.printf "ok %d %d\n" i_5 j_6 done
+done>.
+*)
+!. .<for i=1 to 2 do
+ for j=1 to 3 do Printf.printf "ok %d %d\n" i j done done>.;;
+(*
+ok 1 1
+ok 1 2
+ok 1 3
+ok 2 1
+ok 2 2
+ok 2 3
+*)
+
+let c = .<for i=1 to 2 do .~(let x = .<i>. in
+ .<for i=1 to 3 do Printf.printf "ok %d %d\n" i .~x done>.) done>.;;
+(*
+val c : unit code = .<
+ for i_9 = 1 to 2 do
+ for i_10 = 1 to 3 do Printf.printf "ok %d %d\n" i_10 i_9 done
+ done>.
+*)
+!. c;;
+(*
+ok 1 1
+ok 2 1
+ok 3 1
+ok 1 2
+ok 2 2
+ok 3 2
+*)
+
+(* Anonymous loop variable (new in 4.02?) *)
+.<for _ = 1 to 3 do print_string "ok" done>.;;
+(*
+- : unit code = .<for _for_11 = 1 to 3 do Pervasives.print_string "ok" done>.
+*)
+!. .<for _ = 1 to 3 do print_string "ok" done>.;;
+(*
+okokok- : unit = ()
+*)
+
+(* Scope extrusion test *)
+
+.<for i=1 to 10 do .~(let _ = !. .<0>. in .<()>.) done>.;;
+(*
+- : unit code = .<for i_2 = 1 to 10 do () done>.
+*)
+.<for i=1 to 10 do .~(let _ = !. .<i>. in .<()>.) done>.;;
+(*
+Exception:
+Failure
+ "The code built at Characters 6-7:\n .<for i=1 to 10 do .~(let _ = !. .<i>. in .<()>.) done>.;;\n ^\n is not closed: identifier i_3 bound at Characters 6-7:\n .<for i=1 to 10 do .~(let _ = !. .<i>. in .<()>.) done>.;;\n ^\n is free".
+
+Was:
+Characters 14-22:
+ .<fun x -> .~(!. .<x>.; .<1>.)>.;;
+ ^^^^^^^^
+Error: !. error: 'cl not generalizable in ('cl, 'a) code
+*)
+print_endline "Error was expected";;
+
+let r = ref .<0>. in .<for i=1 to 5 do .~(r := .<0>.; .<()>.) done>.;
+ .<for i=1 to 5 do ignore (.~(!r)) done>.;;
+(*
+- : unit code = .<for i_13 = 1 to 5 do Pervasives.ignore 0 done>.
+*)
+
+let r = ref .<0>. in .<for i=1 to 5 do .~(r := .<i>.; .<()>.) done>.;
+ .<for i=1 to 5 do ignore (.~(!r)) done>.;;
+(*
+Exception:
+Failure
+ "Scope extrusion detected at Characters 110-125:\n .<for i=1 to 5 do ignore (.~(!r)) done>.;;\n ^^^^^^^^^^^^^^^\n for code built at Characters 27-28:\n let r = ref .<0>. in .<for i=1 to 5 do .~(r := .<i>.; .<()>.) done>.; \n ^\n for the identifier i_3 bound at Characters 27-28:\n let r = ref .<0>. in .<for i=1 to 5 do .~(r := .<i>.; .<()>.) done>.; \n ^\n".
+*)
+print_endline "Error was expected";;
+
+(* Better error message *)
+let r = ref .<0>. in .<for i=1 to 5 do .~(r := .<i+1>.; .<()>.) done>.;
+ .<for i=1 to 5 do ignore (.~(!r)) done>.;;
+
+(*
+Characters 21-70:
+ let r = ref .<0>. in .<for i=1 to 5 do .~(r := .<i+1>.; .<()>.) done>.;
+ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Warning 10: this expression should have type unit.
+Exception:
+Failure
+ "Scope extrusion detected at Characters 112-127:\n .<for i=1 to 5 do ignore (.~(!r)) done>.;;\n ^^^^^^^^^^^^^^^\n for code built at Characters 49-52:\n let r = ref .<0>. in .<for i=1 to 5 do .~(r := .<i+1>.; .<()>.) done>.; \n ^^^\n for the identifier i_16 bound at Characters 27-28:\n let r = ref .<0>. in .<for i=1 to 5 do .~(r := .<i+1>.; .<()>.) done>.; \n ^\n".
+*)
+print_endline "Error was expected";;
+
+(* Simple functions *)
+.<fun x -> x>.;;
+(*
+- : ('a -> 'a) code = .<fun x_7 -> x_7>.
+*)
+let 42 = (!. .<fun x -> x>.) 42;;
+
+.<fun x y -> x + y>.;;
+(*
+- : (int -> int -> int) code = .<fun x_9 y_10 -> x_9 + y_10>.
+*)
+let 5 = (!. .<fun x y -> x + y>.) 2 3;;
+
+.<fun x -> fun x -> x + x >.;;
+(*
+- : ('a -> int -> int) code = .<fun x_13 x_14 -> x_14 + x_14>.
+*)
+let 8 = !. .<fun x -> fun x -> x + x >. 3 4;;
+
+(* Testing hygiene *)
+let eta f = .<fun x -> .~(f .<x>.)>.;;
+(*
+val eta : ('a code -> 'b code) -> ('a -> 'b) code = <fun>
+*)
+eta (fun x -> .<1 + .~x>.);;
+(*
+- : (int -> int) code = .<fun x_17 -> 1 + x_17>.
+*)
+eta (fun y -> .<fun x -> x + .~y>.);;
+(*
+- : (int -> int -> int) code = .<fun x_18 x_19 -> x_19 + x_18>.
+*)
+let 5 = (!. (eta (fun y -> .<fun x -> x + .~y>.))) 2 3;;
+
+(* new identifiers must be generated at run-time *)
+let rec fhyg = fun y -> function
+ | 0 -> y
+ | n -> .<(fun x -> .~(fhyg .<.~y + x>. (n-1))) n>.;;
+(*
+val fhyg : int -> int code = <fun>
+*)
+fhyg .<1>. 3;;
+(*
+- : int code = .<
+(fun x_7 -> (fun x_8 -> (fun x_9 -> ((1 + x_7) + x_8) + x_9) 1) 2) 3>.
+*)
+let 7 = !. (fhyg .<1>. 3);;
+
+(* pattern-matching, general functions *)
+
+.<fun () -> 1>.;;
+(* - : (unit -> int) code = .<fun () -> 1>. *)
+!. .<fun () -> 1>.;;
+(* - : unit -> int = <fun> *)
+let 1 = (!. .<fun () -> 1>.) ();;
+
+.<function true -> 1 | false -> 0>.;;
+(*
+- : (bool -> int) code = .<function | true -> 1 | false -> 0>.
+*)
+let 1 = (!. .<function true -> 1 | false -> 0>.) true;;
+
+.<fun (true,[]) -> 1>.;;
+(*
+- : (bool * 'a list -> int) code = .<fun (true, []) -> 1>.
+*)
+(!. .<fun (true,[]) -> 1>.) (true,[1]);;
+(*
+Exception: Match_failure ("//toplevel//", 1, 6).
+*)
+print_endline "Error was expected";;
+let 1 = (!. .<fun (true,[]) -> 1>.) (true,[]);;
+
+.<fun [|true;false;false|] -> 1>.;;
+(*
+- : (bool array -> int) code = .<fun [|true; false; false|] -> 1>.
+*)
+let 1 = (!. .<fun [|true;false;false|] -> 1>.) [|true;false;false|];;
+
+.<function `F 1 -> true | _ -> false>.;;
+(*
+- : ([> `F of int ] -> bool) code = .<function | `F 1 -> true | _ -> false>.
+*)
+let true = (!. .<function `F 1 -> true | _ -> false>.) (`F 1);;
+.<function `F 1 | `G 2 -> true | _ -> false>.;;
+(*
+- : ([> `F of int | `G of int ] -> bool) code = .<
+function | `F 1|`G 2 -> true | _ -> false>.
+*)
+
+.<function (1,"str") -> 1 | (2,_) -> 2>.;;
+(*
+- : (int * string -> int) code = .<function | (1,"str") -> 1 | (2,_) -> 2>.
+*)
+let 1 = (!. .<function (1,"str") -> 1 | (2,_) -> 2>.) (1,"str");;
+let 2 = (!. .<function (1,"str") -> 1 | (2,_) -> 2>.) (2,"str");;
+let 1 = (!. .<fun [1;2] -> 1>.) [1;2];;
+
+let 2 = (!. .<function None -> 1 | Some [1] -> 2>.) (Some [1]);;
+
+let 2 = (!. .<function (Some (Some true)) -> 1 | _ -> 2>.) (Some None);;
+let 1 = (!. .<function (Some (Some true)) -> 1 | _ -> 2>.) (Some (Some true));;
+let 2 = (!. .<function (Some (Some true)) -> 1 | _ -> 2>.) (Some (Some false));;
+let 2 = (!. .<function (Some (Some true)) -> 1 | _ -> 2>.) None;;
+
+open Complex;;
+.<function {re=1.0} -> 1 | {im=2.0; re = 2.0} -> 2 | {im=_} -> 3>.;;
+(*
+- : (Complex.t -> int) code = .<
+function
+| { Complex.re = 1.0 } -> 1
+| { Complex.re = 2.0; Complex.im = 2.0 } -> 2
+| { Complex.im = _ } -> 3>.
+*)
+
+let 1 = (!. .<function {re=1.0} -> 1 | {im=2.0; re = 2.0} -> 2 | {im=_} -> 3>.)
+ {re=1.0; im=2.0};;
+let 2 = (!. .<function {re=1.0} -> 1 | {im=2.0; re = 2.0} -> 2 | {im=_} -> 3>.)
+ {re=2.0; im=2.0};;
+(* - : int = 2 *)
+let 3 = (!. .<function {re=1.0} -> 1 | {im=2.0; re = 2.0} -> 2 | {im=_} -> 3>.)
+ {re=2.0; im=3.0};;
+
+(* General functions *)
+
+(* Non-binding pattern *)
+.<fun () -> 1>.;;
+(*
+- : (unit -> int) code = .<fun () -> 1>.
+*)
+let 1 = !. .<fun () -> 1>. ();;
+
+(* .<fun (type a) () -> 1>.;; *)
+
+.<fun _ -> true>.;;
+(* - : ('a -> bool) code = .<fun _ -> true>. *)
+let true = !. .<fun _ -> true>. 1;;
+
+.<fun (x,y) -> x + y>.;;
+(*
+- : (int * int -> int) code = .<fun (x_1,y_2) -> x_1 + y_2>.
+*)
+let 5 = (!. .<fun (x,y) -> x + y>.) (2,3);;
+.<function (Some x) as y -> x | _ -> 2>.;;
+(*
+- : (int option -> int) code = .<function | Some x_5 as y_6 -> x_5 | _ -> 2>.
+*)
+let 1 = (!. .<function (Some x) as y -> x | _ -> 2>.) (Some 1);;
+let 2 = (!. .<function (Some x) as y -> x | _ -> 2>.) None;;
+.<function [x;y;z] -> x - y + z | [x;y] -> x - y>.;;
+(*
+- : (int list -> int) code = .<
+function
+| x_11::y_12::z_13::[] -> (x_11 - y_12) + z_13
+| x_14::y_15::[] -> x_14 - y_15>.
+*)
+let 2 = (!. .<function [x;y;z] -> x - y + z | [x;y] -> x - y>.) [1;2;3];;
+
+ (* OR patterns *)
+.<function ([x;y] | [x;y;_]) -> x - y>.;;
+(*
+- : (int list -> int) code = .<
+fun (x_21::y_22::[]|x_21::y_22::_::[]) -> x_21 - y_22>.
+*)
+let -1 = (!. .<function ([x;y] | [x;y;_]) -> x - y>.) [1;2];;
+let -1 = (!. .<function ([x;y] | [x;y;_]) -> x - y>.) [1;2;3];;
+(!. .<function ([x;y] | [x;y;_]) -> x - y>.) [1;2;3;4];;
+(* Exception: Match_failure ("//toplevel//", 1, 6). *)
+print_endline "Error was expected";;
+
+.<function ([x;y] | [x;y;_]| [y;x;_;_]) -> x - y>.;;
+(*
+- : (int list -> int) code = .<
+fun (x_29::y_30::[]|x_29::y_30::_::[]|y_30::x_29::_::_::[]) -> x_29 - y_30>.
+*)
+let -1 = (!. .<function ([x;y] | [x;y;_]| [y;x;_;_]) -> x - y>.) [1;2];;
+let -1 = (!. .<function ([x;y] | [x;y;_]| [y;x;_;_]) -> x - y>.) [1;2;3];;
+let 1 = (!. .<function ([x;y] | [x;y;_]| [y;x;_;_]) -> x - y>.) [1;2;3;4];;
+
+.<function (`F x | `G x) -> x | `E x -> x>.;;
+(*
+- : ([< `E of 'a | `F of 'a | `G of 'a ] -> 'a) code = .<
+function | `F x_37|`G x_37 -> x_37 | `E x_38 -> x_38>.
+*)
+let 2 = (!. .<function (`F x | `G x) -> x | `E x -> x>.) (`F 2);;
+open Complex;;
+.<function {re=x} -> x | {im=x; re=y} -> x -. y>.;;
+(*
+- : (Complex.t -> float) code = .<
+function
+| { Complex.re = x_41 } -> x_41
+| { Complex.re = y_42; Complex.im = x_43 } -> x_43 -. y_42>.
+*)
+.<function {re=x; im=2.0} -> x | {im=x; re=y} -> x -. y>.;;
+(*
+- : (Complex.t -> float) code = .<
+function
+| { Complex.re = x_44; Complex.im = 2.0 } -> x_44
+| { Complex.re = y_45; Complex.im = x_46 } -> x_46 -. y_45>.
+*)
+let 0. = (!. .<function {re=x; im=2.0} -> x | {im=x; re=y} -> x -. y>.)
+ {re=1.0; im=1.0};;
+let 1. = (!. .<function {re=x; im=2.0} -> x | {im=x; re=y} -> x -. y>.)
+ {re=1.0; im=2.0};;
+.<function (Some x) as y when x > 0 -> y | _ -> None>.;;
+(*
+- : (int option -> int option) code = .<
+function | Some x_53 as y_54 when x_53 > 0 -> y_54 | _ -> None>.
+*)
+let Some 1 = (!. .<function (Some x) as y when x > 0 -> y | _ -> None>.)
+ (Some 1);;
+let None = (!. .<function (Some x) as y when x > 0 -> y | _ -> None>.)
+ (Some 0);;
+
+(* pattern-matching *)
+.<match 1 with 1 -> true>.;;
+(*
+- : bool code = .<match 1 with | 1 -> true>.
+*)
+let true = !. .<match 1 with 1 -> true>.;;
+
+.<match (1,2) with (1,x) -> true | x -> false>.;;
+(*
+- : bool code = .<match (1, 2) with | (1,x_5) -> true | x_6 -> false>.
+*)
+.<match [1;2] with [x] -> x | [x;y] -> x + y>.;;
+(*
+- : int code = .<
+match [1; 2] with | x_7::[] -> x_7 | x_8::y_9::[] -> x_8 + y_9>.
+*)
+let 3 =
+ !. .<match [1;2] with [x] -> x | [x;y] -> x + y>.;;
+
+(* OR patterns *)
+.<match [1;2] with [x] -> x | [x;y] | [x;y;_] -> x + y>.;;
+(*
+- : int code = .<
+match [1; 2] with
+| x_13::[] -> x_13
+| x_14::y_15::[]|x_14::y_15::_::[] -> x_14 + y_15>.
+*)
+let 3 = !. .<match [1;2] with [x] -> x | [x;y] | [x;y;_] -> x + y>.;;
+
+.<match [1;2;3;4] with [x] -> x | [x;y] | [x;y;_] | [y;x;_;_] -> x - y>.;;
+(*
+- : int code = .<
+match [1; 2; 3; 4] with
+| x_19::[] -> x_19
+| x_20::y_21::[]|x_20::y_21::_::[]|y_21::x_20::_::_::[] -> x_20 - y_21>.
+*)
+let 1 =
+ !. .<match [1;2;3;4] with [x] -> x | [x;y] | [x;y;_] | [y;x;_;_] -> x - y>.;;
+
+.<fun x -> match x with (`F x | `G x) -> x | `E x -> x>.;;
+(*
+- : ([< `E of 'a | `F of 'a | `G of 'a ] -> 'a) code = .<
+fun x_25 -> match x_25 with | `F x_26|`G x_26 -> x_26 | `E x_27 -> x_27>.
+*)
+
+let 1 = (!. .<fun x -> match x with (`F x | `G x) -> x | `E x -> x>.) (`G 1);;
+
+open Complex;;
+.<fun x -> match x with {re=x; im=2.0} -> x | {im=x; re=y} -> x -. y>.;;
+(*
+- : (Complex.t -> float) code = .<
+fun x_31 ->
+ match x_31 with
+ | { Complex.re = x_32; Complex.im = 2.0 } -> x_32
+ | { Complex.re = y_33; Complex.im = x_34 } -> x_34 -. y_33>.
+*)
+
+let 1.0 =
+ (!. .<fun x -> match x with {re=x; im=2.0} -> x | {im=x; re=y} -> x -. y>.)
+ {im=2.0; re=1.0};;
+
+(* exceptional cases *)
+.<match List.mem 1 [] with x -> x | exception Not_found -> false>.;;
+(*
+- : bool code = .<
+match List.mem 1 [] with | x_95 -> x_95 | exception Not_found -> false>.
+*)
+let false =
+ !. .<match List.mem 1 [] with x -> x | exception Not_found -> false>.
+
+let f = .<fun x ->
+ match List.assoc 1 x with "1" as x -> x | x -> x
+ | exception Not_found -> "" | exception Invalid_argument x -> x>.
+(*
+val f : ((int * string) list -> string) code = .<
+ fun x_100 ->
+ match List.assoc 1 x_100 with
+ | "1" as x_101 -> x_101
+ | x_102 -> x_102
+ | exception Not_found -> ""
+ | exception Invalid_argument x_103 -> x_103>.
+*)
+let "" = !. f []
+let "1" = !. f [(1,"1")]
+let "0" = !. f [(1,"0")];;
+
+(* try *)
+.<fun x -> try Some (List.assoc x [(1,true); (2,false)]) with Not_found -> None>.;;
+(*
+- : (int -> bool option) code = .<
+fun x_39 ->
+ try Some (List.assoc x_39 [(1, true); (2, false)])
+ with | Not_found -> None>.
+*)
+let Some true =
+ (!. .<fun x -> try Some (List.assoc x [(1,true); (2,false)]) with Not_found -> None>.) 1;;
+let Some false =
+ (!. .<fun x -> try Some (List.assoc x [(1,true); (2,false)]) with Not_found -> None>.) 2;;
+let None =
+ (!. .<fun x -> try Some (List.assoc x [(1,true); (2,false)]) with Not_found -> None>.) 3;;
+
+.<fun x -> let open Scanf in try sscanf x "%d" (fun x -> string_of_int x) with Scan_failure x -> "fail " ^ x>.;;
+(*
+- : (string -> string) code = .<
+fun x_43 ->
+ let open Scanf in
+ try Scanf.sscanf x_43 "%d" (fun x_44 -> Pervasives.string_of_int x_44)
+ with | Scanf.Scan_failure x_45 -> "fail " ^ x_45>.
+*)
+
+let "1" =
+ (!. .<fun x -> let open Scanf in try sscanf x "%d" (fun x -> string_of_int x) with Scan_failure x -> "fail " ^ x>.) "1";;
+let "fail scanf: bad input at char number 0: \"character 'x' is not a decimal digit\"" =
+ (!. .<fun x -> let open Scanf in try sscanf x "%d" (fun x -> string_of_int x) with Scan_failure x -> "fail " ^ x>.) "xxx";;
+
+(* Simple let *)
+
+.<let x = 1 in x>.;;
+(*
+- : int code = .<let x_1 = 1 in x_1>.
+*)
+let 1 =
+ !. .<let x = 1 in x>.;;
+.<let x = 1 in let x = x + 1 in x>.;;
+(*
+- : int code = .<let x_55 = 1 in let x_56 = x_55 + 1 in x_56>.
+*)
+let 2 =
+ !. .<let x = 1 in let x = x + 1 in x>.;;
+.<let rec f = fun n -> if n = 0 then 1 else n * f (n-1) in f 5>.;;
+(*
+- : int code = .<
+let rec f_7 n_8 = if n_8 = 0 then 1 else n_8 * (f_7 (n_8 - 1)) in f_7 5>.
+*)
+let 120 =
+ !. .<let rec f = fun n -> if n = 0 then 1 else n * f (n-1) in f 5>.;;
+
+(* Recursive vs. non-recursive bindings *)
+.<let f = fun x -> x in
+ let rec f = fun n -> if n = 0 then 1 else n * f (n-1) in f 5>.;;
+(*
+ Characters 6-7:
+ .<let f = fun x -> x in
+ ^
+Warning 26: unused variable f.
+- : int code = .<
+let f_12 x_11 = x_11 in
+let rec f_13 n_14 = if n_14 = 0 then 1 else n_14 * (f_13 (n_14 - 1)) in
+f_13 5>.
+*)
+
+let 120 = !. .<let f = fun x -> x in
+ let rec f = fun n -> if n = 0 then 1 else n * f (n-1) in f 5>.;;
+
+.<let f = fun x -> x in
+ let f = fun n -> if n = 0 then 1 else n * f (n-1) in f 5>.;;
+(*
+ - : int code = .<
+let f_20 x_19 = x_19 in
+let f_22 n_21 = if n_21 = 0 then 1 else n_21 * (f_20 (n_21 - 1)) in f_22 5>.
+*)
+let 20 = !. .<let f = fun x -> x in
+ let f = fun n -> if n = 0 then 1 else n * f (n-1) in f 5>.;;
+
+.<let g = fun x -> x+10 in
+ let f = fun x -> g x + 20
+ and g = fun n -> if n = 0 then 1 else n * g (n-1) in (f 5,g 5)>.;;
+
+(*
+- : (int * int) code = .<
+let g_28 x_27 = x_27 + 10 in
+let f_29 x_32 = (g_28 x_32) + 20
+and g_30 n_31 = if n_31 = 0 then 1 else n_31 * (g_28 (n_31 - 1)) in
+((f_29 5), (g_30 5))>.
+*)
+let (35,70) = !. .<let g = fun x -> x+10 in
+ let f = fun x -> g x + 20
+ and g = fun n -> if n = 0 then 1 else n * g (n-1) in (f 5,g 5)>.;;
+
+.<let g = fun x -> x+10 in
+ let rec f = fun x -> g x + 20
+ and g = fun n -> if n = 0 then 1 else n * g (n-1) in (f 5,g 5)>.;;
+
+(*
+Characters 6-7:
+ .<let g = fun x -> x+10 in
+ ^
+Warning 26: unused variable g.
+- : (int * int) code = .<
+let g_40 x_39 = x_39 + 10 in
+let rec f_41 x_44 = (g_42 x_44) + 20
+and g_42 n_43 = if n_43 = 0 then 1 else n_43 * (g_42 (n_43 - 1)) in
+((f_41 5), (g_42 5))>.
+*)
+
+let (140,120) =
+ !. .<let g = fun x -> x+10 in
+ let rec f = fun x -> g x + 20
+ and g = fun n -> if n = 0 then 1 else n * g (n-1) in (f 5,g 5)>.;;
+
+.<let rec [] = [] in []>.
+(*
+Characters 10-12:
+ .<let rec [] = [] in []>.;;
+ ^^
+Only variables are allowed as left-hand side of `let rec'
+*)
+print_endline "Error was expected";;
+
+.<let rec f = f in f>.
+(*
+Characters 10-15:
+ .<let rec f = f in f>.;;
+ ^^^^^
+Recursive let binding must be to a function
+*)
+print_endline "Error was expected";;
+
+(* General let rec *)
+.<fun x -> let rec even = function 0 -> true | x -> odd (x-1) and
+ odd = function 0 -> false | x -> even (x-1) in even x>.;;
+(*
+ - : (int -> bool) code = .<
+fun x_80 ->
+ let rec even_81 = function | 0 -> true | x_84 -> odd_82 (x_84 - 1)
+ and odd_82 = function | 0 -> false | x_83 -> even_81 (x_83 - 1) in
+ even_81 x_80>.
+*)
+let true = (!. .<fun x -> let rec even = function 0 -> true | x -> odd (x-1) and odd = function 0 -> false | x -> even (x-1) in even x>.) 42;;
+let false = (!. .<fun x -> let rec even = function 0 -> true | x -> odd (x-1) and odd = function 0 -> false | x -> even (x-1) in even x>.) 43;;
+
+
+(* General let *)
+.<let x = 1 and y = 2 in x + y>.;;
+(*
+- : int code = .<let x_73 = 1 and y_74 = 2 in x_73 + y_74>.
+*)
+let 3 = !. .<let x = 1 and y = 2 in x + y>.;;
+
+.<let x = 1 in let x = x+1 and y = x+1 in x + y>.;;
+(*
+- : int code = .<
+let x_77 = 1 in let x_78 = x_77 + 1 and y_79 = x_77 + 1 in x_78 + y_79>.
+*)
+let 4 = !. .<let x = 1 in let x = x+1 and y = x+1 in x + y>.;;
+.<fun x -> let (Some x) = x in x + 1>.;;
+(*
+Characters 15-23:
+ .<fun x -> let (Some x) = x in x + 1>.;;
+ ^^^^^^^^
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a value that is not matched:
+None
+- : (int option -> int) code = .<
+fun x_83 -> let Some x_84 = x_83 in x_84 + 1>.
+*)
+let 3 = (!. .<fun x -> let (Some x) = x in x + 1>.) (Some 2);;
+(!. .<fun x -> let (Some x) = x in x + 1>.) None;;
+(*
+Exception: Match_failure ("//toplevel//", 1, 19).
+*)
+print_endline "Error was expected";;
+
+
+
+(* testing scope extrusion *)
+let r = ref .<0>. in let _ = .<fun x -> .~(r := .<1>.; .<0>.)>. in !r ;;
+(* - : int code = .<1>. *)
+let r = ref .<0>. in let _ = .<fun x -> .~(r := .<x>.; .<0>.)>. in !r ;;
+(*
+- : int code = .<x_30>.
+
+Failure("The code built at Characters 35-36:\n let r = ref .<0>. in let _ = .<fun x -> .~(r := .<x>.; .<0>.)>. in !r ;;\n ^\n is not closed: identifier x_30 bound at Characters 35-36:\n let r = ref .<0>. in let _ = .<fun x -> .~(r := .<x>.; .<0>.)>. in !r ;;\n ^\n is free")
+*)
+print_endline "Error was expected";;
+
+let c = let r = ref .<0>. in let _ = .<fun x -> .~(r := .<x>.; .<0>.)>. in (!r) in !. c;;
+(*
+Exception:
+Failure
+ "The code built at Characters 43-44:\n let c = let r = ref .<0>. in let _ = .<fun x -> .~(r := .<x>.; .<0>.)>. in (!r) in !. c;;\n ^\n is not closed: identifier x_31 bound at Characters 43-44:\n let c = let r = ref .<0>. in let _ = .<fun x -> .~(r := .<x>.; .<0>.)>. in (!r) in !. c;;\n ^\n is free".
+*)
+print_endline "Error was expected";;
+
+let r = ref .<fun y->y>. in let _ = .<fun x -> .~(r := .<fun y -> x>.; .<0>.)>. in !r ;;
+(*
+- : ('_a -> '_a) code = .<fun y_34 -> x_33>.
+
+Failure("The code built at Characters 57-67:\n let r = ref .<fun y->y>. in let _ = .<fun x -> .~(r := .<fun y -> x>.; .<0>.)>. in !r ;;\n ^^^^^^^^^^\n is not closed: identifier x_33 bound at Characters 42-43:\n let r = ref .<fun y->y>. in let _ = .<fun x -> .~(r := .<fun y -> x>.; .<0>.)>. in !r ;;\n ^\n is free")
+
+*)
+print_endline "Error was expected";;
+
+(* Error message is reported on splice *)
+let r = ref .<fun y->y>. in
+ let _ = .<fun x -> .~(r := .<fun y -> x>.; .<0>.)>. in .<fun x -> .~(!r) 1>. ;;
+(*
+Exception:
+Failure
+ "Scope extrusion detected at Characters 96-104:\n let _ = .<fun x -> .~(r := .<fun y -> x>.; .<0>.)>. in .<fun x -> .~(!r) 1>. ;;\n ^^^^^^^^\n for code built at Characters 59-69:\n let _ = .<fun x -> .~(r := .<fun y -> x>.; .<0>.)>. in .<fun x -> .~(!r) 1>. ;;\n ^^^^^^^^^^\n for the identifier x_95 bound at Characters 44-45:\n let _ = .<fun x -> .~(r := .<fun y -> x>.; .<0>.)>. in .<fun x -> .~(!r) 1>. ;;\n ^\n".
+*)
+print_endline "Error was expected";;
+
+(* Unlike BER N100, the test is exact. The following is accepted with BER N101
+ (it wasn't with BER N100)
+*)
+let r = ref .<fun y->y>. in let _ = .<fun x -> .~(r := .<fun y -> y>.; .<0>.)>. in !r ;;
+(*
+- : ('_a -> '_a) code = .<fun y_41 -> y_41>.
+*)
+(* Was in N100: print_endline "Error was expected";; *)
+
+(* The following are OK though *)
+let r = ref .<fun y->y>. in .<fun x -> .~(r := .<fun y -> y>.; !r)>.;;
+(*
+- : ('_a -> '_b -> '_b) code = .<fun x_43 y_44 -> y_44>.
+*)
+let r = ref .<fun y->y>. in .<fun x -> .~(r := .<fun y -> x>.; !r)>.;;
+(*
+- : ('_a -> '_a -> '_a) code = .<fun x_46 y_47 -> x_46>.
+*)
+let 3 =
+ let r = ref .<fun y->y>. in !. .<fun x -> .~(r := .<fun y -> x>.; !r)>. 3 4;;
+
+print_endline "\nAll done\n";;
diff -Naur ocaml-4.02.1/metalib/trivial.ref ocaml-ber-n102/metalib/trivial.ref
--- ocaml-4.02.1/metalib/trivial.ref 1970-01-01 01:00:00.000000000 +0100
+++ ocaml-ber-n102/metalib/trivial.ref 2015-01-10 16:27:06.936030975 +0000
@@ -0,0 +1,460 @@
+BER MetaOCaml toplevel, version N 102
+ OCaml version 4.02.1
+
+# # - : int = 5
+# val fact : int -> int = <fun>
+# # - : int code = .<1>.
+# - : string code = .<"aaa">.
+# # - : int Runcode.closed_code = .<1>.
+# * * - : 'a list -> 'a list = <fun>
+# - : ('a list -> 'a list) code = .<List.rev>.
+# Characters 74-75:
+ .<fun x -> .~(let y = x in y)>.;;
+ ^
+Wrong level: variable bound at level 1 and used at level 0
+# * * * * * Error was expected
+- : unit = ()
+# Characters 18-28:
+ .<fun x -> 1 + .~(.<true>.)>.;;
+ ^^^^^^^^^^
+Error: This expression has type bool but an expression was expected of type
+ int
+# * * * * * * Error was expected
+- : unit = ()
+# - : int code = .<1>.
+# * * - : float code = .<1.>.
+# * * - : bool code = .<true>.
+# * * - : string code = .<"aaa">.
+# * * - : char code = .<'a'>.
+# * * - : char list code = .<(* CSP x *)>.
+# * * val l : 'a -> 'a code = <fun>
+# - : int code = .<(* CSP x *) Obj.magic 1>.
+# * * # - : float code = .<1.>.
+# * * # - : 'a list code = .<(* CSP x *) Obj.magic 0>.
+# * * # - : (int -> int) code = .<(* CSP x *)>.
+# * * * * * * - : ('a list -> 'a list) code = .<List.rev>.
+# * * - : ('a array -> int -> 'a) code = .<Array.get>.
+# * * - : (int -> int -> int) code = .<Pervasives.(+)>.
+# * * - : unit code = .<assert true>.
+# * * - : unit = ()
+# - : int code = .<Pervasives.succ 1>.
+# * * # - : int code = .<1 + 2>.
+# * * # - : int code = .<String.length "abc">.
+# * * # - : string code = .<StringLabels.sub "abc" ~pos:1 ~len:2>.
+# * * # - : string code = .<StringLabels.sub "abc" ~pos:1 ~len:2>.
+# * * # - : int code code = .<.< 1 >.>.
+# - : int code = .<1>.
+# # - : int code = .<Runcode.(!.) .< 1 >.>.
+# * * # - : int code = .<1 + 2>.
+# * * - : int code = .<(2 + 4) + (2 + 4)>.
+# * * # Characters 27-28:
+ .<1 + .~(let x = 2 in .<.<x>.>.)>.;;
+ ^
+Error: This expression has type 'a code
+ but an expression was expected of type int
+# * * * * * Error was expected
+- : unit = ()
+# - : int code = .<1 + (Runcode.(!.) .< 2 >.)>.
+# * * # Characters 12-40:
+ !. .<1 + .~ (.~(let x = 2 in .<.<x>.>.))>.;;
+ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Wrong level: escape at level 0
+# * * * * * Error was expected
+- : unit = ()
+# - : int code code = .<.< .~(.< 1 >.) >.>.
+# * * * - : int code = .<1>.
+# * * # - : int code code = .<.< .~(.< 1 >.) >.>.
+# * * * # - : int code = .<1>.
+# * * # - : int code code = .<(* CSP x *)>.
+# * * - : int code = .<1>.
+# * * # - : int code code = .<.< .~((* CSP x *)) >.>.
+# * * # - : ('a list -> 'a list) code code = .<.< .~(.< List.rev >.) >.>.
+# * * - : ('_a list -> '_a list) code = .<List.rev>.
+# * * # * * - : int code code = .<.< assert true; 1 >.>.
+# * * # - : int code = .<assert true; 1>.
+# * * - : int code = .<assert true; 1>.
+# * * - : int code = .<assert true; 1>.
+# * * # - : int code = .<assert true; 1>.
+# * * - : int lazy_t code = .<lazy 1>.
+# * * # - : (int * string) code = .<(1, "abc")>.
+# * * - : (int * string * char) code = .<(1, "abc", 'd')>.
+# * * # - : 'a array code = .<[||]>.
+# * * - : int array code = .<[|(1 + 2);(1 + 2)|]>.
+# * * - : 'a code = .<Pervasives.raise Not_found>.
+# * * Characters 52-64:
+ .<raise (Scan_failure "")>.;;
+ ^^^^^^^^^^^^
+Error: Unbound constructor Scan_failure
+# * * * * * Error was expected
+- : unit = ()
+# - : 'a code = .<Pervasives.raise (Scanf.Scan_failure "")>.
+# * * # - : 'a code = .<Pervasives.raise (Scanf.Scan_failure "")>.
+# * * Exception: Scanf.Scan_failure "".
+# * * Exception was expected
+- : unit = ()
+# - : bool code = .<true>.
+# * * - : int option code = .<Some 1>.
+# * * - : int list option code = .<Some [1]>.
+# * * # - : 'a option code = .<None>.
+# * * # - : Genlex.token code = .<Genlex.Int 1>.
+# * * # - : Genlex.token code = .<Genlex.Int 1>.
+# * * # module Foo : sig exception E end
+# Characters 8-13:
+ .<raise Foo.E>.;;
+ ^^^^^
+Exception (extension) Foo.E cannot be used within brackets. Put into a separate file.
+# * * * * * Error was expected
+- : unit = ()
+# type foo = Bar
+# Characters 2-5:
+ .<Bar>.;;
+ ^^^
+Unqualified constructor Bar cannot be used within brackets. Put into a separate file.
+# * * * * * Error was expected
+- : unit = ()
+# module Foo : sig type foo = Bar end
+# Characters 2-9:
+ .<Foo.Bar>.;;
+ ^^^^^^^
+Constructor Bar cannot be used within brackets. Put into a separate file.
+# * * * * * Error was expected
+- : unit = ()
+# - : Complex.t code = .<{ Complex.re = 1.0; Complex.im = 2.0 }>.
+# * * # - : float code = .<(* CSP x *).Complex.re>.
+# * * * * * * * * - : float code = .<(* CSP x *).Complex.re>.
+# * * * # - : int code = .<(* CSP x *).Pervasives.contents>.
+# * * # - : unit code = .<(* CSP x *).Pervasives.contents <- 2>.
+# * * * - : int ref = {contents = 2}
+# # - : Complex.t code = .<{ Complex.re = 1.0; Complex.im = 2.0 }>.
+# * * # - : float code = .<(* CSP x *).Complex.re>.
+# * * * # type foo = { fool : int; }
+# Characters 3-7:
+ .<{fool = 1}>.;;
+ ^^^^
+Unqualified label fool cannot be used within brackets. Put into a separate file.
+# * * * * * Error was expected
+- : unit = ()
+# - : int code = .<if true then 1 else 2>.
+# - : unit code = .<if (Some 1) = None then Pervasives.print_string "weird">.
+# * * # - : [> `Foo ] code = .<`Foo>.
+# * * - : [> `Bar of int ] code = .<`Bar 1>.
+# * * # val f : < foo : 'a; .. > -> 'a code = <fun>
+# * * val x : < foo : int > = <obj>
+# * * - : int code = .<(* CSP x *)#foo>.
+# * * # - : float code = .<Complex.norm { Complex.re = 3.0; Complex.im = 4.0 }>.
+# * * # - : float code = .<Complex.norm { Complex.re = 4.0; Complex.im = 3.0 }>.
+# * * # - : unit code = .<
+for i_1 = 1 to 5 do
+ Printf.printf
+ (CamlinternalFormatBasics.Format
+ ((CamlinternalFormatBasics.String_literal
+ ("ok ",
+ (CamlinternalFormatBasics.Int
+ (CamlinternalFormatBasics.Int_d,
+ CamlinternalFormatBasics.No_padding,
+ CamlinternalFormatBasics.No_precision,
+ (CamlinternalFormatBasics.Char_literal
+ (' ',
+ (CamlinternalFormatBasics.Int
+ (CamlinternalFormatBasics.Int_d,
+ CamlinternalFormatBasics.No_padding,
+ CamlinternalFormatBasics.No_precision,
+ (CamlinternalFormatBasics.Char_literal
+ ('\n', CamlinternalFormatBasics.End_of_format)))))))))),
+ "ok %d %d\n")) i_1 (i_1 + 1)
+done>.
+# * * * ok 1 2
+ok 2 3
+ok 3 4
+ok 4 5
+ok 5 6
+- : unit = ()
+# * * * * * * - : unit code = .<
+for i_3 = 5 downto 1 do
+ Printf.printf
+ (CamlinternalFormatBasics.Format
+ ((CamlinternalFormatBasics.String_literal
+ ("ok ",
+ (CamlinternalFormatBasics.Int
+ (CamlinternalFormatBasics.Int_d,
+ CamlinternalFormatBasics.No_padding,
+ CamlinternalFormatBasics.No_precision,
+ (CamlinternalFormatBasics.Char_literal
+ (' ',
+ (CamlinternalFormatBasics.Int
+ (CamlinternalFormatBasics.Int_d,
+ CamlinternalFormatBasics.No_padding,
+ CamlinternalFormatBasics.No_precision,
+ (CamlinternalFormatBasics.Char_literal
+ ('\n', CamlinternalFormatBasics.End_of_format)))))))))),
+ "ok %d %d\n")) i_3 (i_3 + 1)
+done>.
+# * * * ok 5 6
+ok 4 5
+ok 3 4
+ok 2 3
+ok 1 2
+- : unit = ()
+# * * * * * * - : unit code = .<
+for i_5 = 1 to 2 do
+ for j_6 = 1 to 3 do
+ Printf.printf
+ (CamlinternalFormatBasics.Format
+ ((CamlinternalFormatBasics.String_literal
+ ("ok ",
+ (CamlinternalFormatBasics.Int
+ (CamlinternalFormatBasics.Int_d,
+ CamlinternalFormatBasics.No_padding,
+ CamlinternalFormatBasics.No_precision,
+ (CamlinternalFormatBasics.Char_literal
+ (' ',
+ (CamlinternalFormatBasics.Int
+ (CamlinternalFormatBasics.Int_d,
+ CamlinternalFormatBasics.No_padding,
+ CamlinternalFormatBasics.No_precision,
+ (CamlinternalFormatBasics.Char_literal
+ ('\n',
+ CamlinternalFormatBasics.End_of_format)))))))))),
+ "ok %d %d\n")) i_5 j_6
+ done
+done>.
+# * * * * * ok 1 1
+ok 1 2
+ok 1 3
+ok 2 1
+ok 2 2
+ok 2 3
+- : unit = ()
+# * * * * * * * val c : unit code = .<
+ for i_9 = 1 to 2 do
+ for i_10 = 1 to 3 do
+ Printf.printf
+ (CamlinternalFormatBasics.Format
+ ((CamlinternalFormatBasics.String_literal
+ ("ok ",
+ (CamlinternalFormatBasics.Int
+ (CamlinternalFormatBasics.Int_d,
+ CamlinternalFormatBasics.No_padding,
+ CamlinternalFormatBasics.No_precision,
+ (CamlinternalFormatBasics.Char_literal
+ (' ',
+ (CamlinternalFormatBasics.Int
+ (CamlinternalFormatBasics.Int_d,
+ CamlinternalFormatBasics.No_padding,
+ CamlinternalFormatBasics.No_precision,
+ (CamlinternalFormatBasics.Char_literal
+ ('\n',
+ CamlinternalFormatBasics.End_of_format)))))))))),
+ "ok %d %d\n")) i_10 i_9
+ done
+ done>.
+# * * * * * ok 1 1
+ok 2 1
+ok 3 1
+ok 1 2
+ok 2 2
+ok 3 2
+- : unit = ()
+# * * * * * * * - : unit code = .<for _for_11 = 1 to 3 do Pervasives.print_string "ok" done>.
+# * * okokok- : unit = ()
+# * * - : unit code = .<for i_13 = 1 to 10 do () done>.
+# * * Exception:
+Failure
+ "The code built at Characters 62-63:\n .<for i=1 to 10 do .~(let _ = !. .<i>. in .<()>.) done>.;;\n ^\n is not closed: identifier i_14 bound at Characters 62-63:\n .<for i=1 to 10 do .~(let _ = !. .<i>. in .<()>.) done>.;;\n ^\n is free".
+# * * * * * * * * * * Error was expected
+- : unit = ()
+# - : unit code = .<for i_16 = 1 to 5 do Pervasives.ignore 0 done>.
+# * * Exception:
+Failure
+ "Scope extrusion detected at Characters 184-199:\n .<for i=1 to 5 do ignore (.~(!r)) done>.;;\n ^^^^^^^^^^^^^^^\n for code built at Characters 101-102:\n let r = ref .<0>. in .<for i=1 to 5 do .~(r := .<i>.; .<()>.) done>.; \n ^\n for the identifier i_17 bound at Characters 101-102:\n let r = ref .<0>. in .<for i=1 to 5 do .~(r := .<i>.; .<()>.) done>.; \n ^\n".
+# * * * * Error was expected
+- : unit = ()
+# Exception:
+Failure
+ "Scope extrusion detected at Characters 140-155:\n .<for i=1 to 5 do ignore (.~(!r)) done>.;;\n ^^^^^^^^^^^^^^^\n for code built at Characters 77-80:\n let r = ref .<0>. in .<for i=1 to 5 do .~(r := .<i+1>.; .<()>.) done>.; \n ^^^\n for the identifier i_19 bound at Characters 55-56:\n let r = ref .<0>. in .<for i=1 to 5 do .~(r := .<i+1>.; .<()>.) done>.; \n ^\n".
+# * * * * * * * * Error was expected
+- : unit = ()
+# - : ('a -> 'a) code = .<fun x_21 -> x_21>.
+# * * # - : (int -> int -> int) code = .<fun x_23 -> fun y_24 -> x_23 + y_24>.
+# * * # - : ('a -> int -> int) code = .<fun x_27 -> fun x_28 -> x_28 + x_28>.
+# * * # val eta : ('a code -> 'b code) -> ('a -> 'b) code = <fun>
+# * * - : (int -> int) code = .<fun x_31 -> 1 + x_31>.
+# * * - : (int -> int -> int) code = .<fun x_32 -> fun x_33 -> x_33 + x_32>.
+# * * # val fhyg : int code -> int -> int code = <fun>
+# * * - : int code = .<
+(fun x_36 -> (fun x_37 -> (fun x_38 -> ((1 + x_36) + x_37) + x_38) 1) 2) 3>.
+
+# * * * # - : (unit -> int) code = .<fun () -> 1>.
+# - : unit -> int = <fun>
+# # - : (bool -> int) code = .<function | true -> 1 | false -> 0>.
+# * * # - : (bool * 'a list -> int) code = .<fun (true ,[]) -> 1>.
+# * * Exception: Match_failure ("//toplevel//", 526, 6).
+# * * Error was expected
+- : unit = ()
+# # - : (bool array -> int) code = .<fun [|true ;false ;false |] -> 1>.
+# * * # - : ([> `F of int ] -> bool) code = .<function | `F 1 -> true | _ -> false>.
+# * * # - : ([> `F of int | `G of int ] -> bool) code = .<
+function | `F 1|`G 2 -> true | _ -> false>.
+# * * * - : (int * string -> int) code = .<function | (1,"str") -> 1 | (2,_) -> 2>.
+# * * # # # # # # # # # - : (Complex.t -> int) code = .<
+function
+| { Complex.re = 1.0 } -> 1
+| { Complex.re = 2.0; Complex.im = 2.0 } -> 2
+| { Complex.im = _ } -> 3>.
+# * * * * * * # # # - : (unit -> int) code = .<fun () -> 1>.
+# * * # - : ('a -> bool) code = .<fun _ -> true>.
+# # - : (int * int -> int) code = .<fun (x_42,y_43) -> x_42 + y_43>.
+# * * # - : (int option -> int) code = .<
+function | Some x_46 as y_47 -> x_46 | _ -> 2>.
+# * * # # - : (int list -> int) code = .<
+function
+| x_52::y_53::z_54::[] -> (x_52 - y_53) + z_54
+| x_55::y_56::[] -> x_55 - y_56>.
+# * * * * * # - : (int list -> int) code = .<
+fun (x_62::y_63::[]|x_62::y_63::_::[]) -> x_62 - y_63>.
+# * * * # # Exception: Match_failure ("//toplevel//", 590, -90).
+# Error was expected
+- : unit = ()
+# - : (int list -> int) code = .<
+fun (x_70::y_71::[]|x_70::y_71::_::[]|y_71::x_70::_::_::[]) -> x_70 - y_71>.
+# * * * # # # - : ([< `E of 'a | `F of 'a | `G of 'a ] -> 'a) code = .<
+function | `F x_78|`G x_78 -> x_78 | `E x_79 -> x_79>.
+# * * * # # - : (Complex.t -> float) code = .<
+function
+| { Complex.re = x_82 } -> x_82
+| { Complex.re = y_83; Complex.im = x_84 } -> x_84 -. y_83>.
+# * * * * * - : (Complex.t -> float) code = .<
+function
+| { Complex.re = x_85; Complex.im = 2.0 } -> x_85
+| { Complex.re = y_86; Complex.im = x_87 } -> x_87 -. y_86>.
+# * * * * * # # - : (int option -> int option) code = .<
+function | Some x_94 as y_95 when x_94 > 0 -> y_95 | _ -> None>.
+# * * * # # - : bool code = .<match 1 with | 1 -> true>.
+# * * # - : bool code = .<match (1, 2) with | (1,x_100) -> true | x_101 -> false>.
+# * * - : int code = .<
+match [1; 2] with | x_102::[] -> x_102 | x_103::y_104::[] -> x_103 + y_104>.
+# * * * # - : int code = .<
+match [1; 2] with
+| x_108::[] -> x_108
+| x_109::y_110::[]|x_109::y_110::_::[] -> x_109 + y_110>.
+# * * * * * # - : int code = .<
+match [1; 2; 3; 4] with
+| x_114::[] -> x_114
+| x_115::y_116::[]|x_115::y_116::_::[]|y_116::x_115::_::_::[] ->
+ x_115 - y_116>.
+
+# * * * * * # - : ([< `E of 'a | `F of 'a | `G of 'a ] -> 'a) code = .<
+fun x_120 ->
+ match x_120 with | `F x_121|`G x_121 -> x_121 | `E x_122 -> x_122>.
+
+# * * * # # - : (Complex.t -> float) code = .<
+fun x_126 ->
+ match x_126 with
+ | { Complex.re = x_127; Complex.im = 2.0 } -> x_127
+ | { Complex.re = y_128; Complex.im = x_129 } -> x_129 -. y_128>.
+
+# * * * * * * # - : bool code = .<
+match List.mem 1 [] with | x_134 -> x_134 | exception Not_found -> false>.
+# * * * * * * * * * * * val f : ((int * string) list -> string) code = .<
+ fun x_136 ->
+ match List.assoc 1 x_136 with
+ | "1" as x_137 -> x_137
+ | x_138 -> x_138
+ | exception Not_found -> ""
+ | exception Invalid_argument x_139 -> x_139>.
+
+# - : (int -> bool option) code = .<
+fun x_140 ->
+ try Some (List.assoc x_140 [(1, true); (2, false)])
+ with | Not_found -> None>.
+
+# * * * * * # # # - : (string -> string) code = .<
+fun x_144 ->
+ try
+ Scanf.sscanf x_144
+ (CamlinternalFormatBasics.Format
+ ((CamlinternalFormatBasics.Int
+ (CamlinternalFormatBasics.Int_d,
+ CamlinternalFormatBasics.No_padding,
+ CamlinternalFormatBasics.No_precision,
+ CamlinternalFormatBasics.End_of_format)), "%d"))
+ (fun x_145 -> Pervasives.string_of_int x_145)
+ with | Scanf.Scan_failure x_146 -> "fail " ^ x_146>.
+
+# * * * * * * # # - : int code = .<let x_153 = 1 in x_153>.
+# * * # - : int code = .<let x_155 = 1 in let x_156 = x_155 + 1 in x_156>.
+# * * # - : int code = .<
+let rec f_159 n_160 = if n_160 = 0 then 1 else n_160 * (f_159 (n_160 - 1)) in
+f_159 5>.
+# * * * # - : int code = .<
+let f_164 x_163 = x_163 in
+let rec f_165 n_166 = if n_166 = 0 then 1 else n_166 * (f_165 (n_166 - 1)) in
+f_165 5>.
+# * * * * * * * * * # - : int code = .<
+let f_172 x_171 = x_171 in
+let f_174 n_173 = if n_173 = 0 then 1 else n_173 * (f_172 (n_173 - 1)) in
+f_174 5>.
+# * * * * # - : (int * int) code = .<
+let g_180 x_179 = x_179 + 10 in
+let f_181 x_184 = (g_180 x_184) + 20
+and g_182 n_183 = if n_183 = 0 then 1 else n_183 * (g_180 (n_183 - 1)) in
+((f_181 5), (g_182 5))>.
+# * * * * * * # - : (int * int) code = .<
+let g_192 x_191 = x_191 + 10 in
+let rec f_193 x_196 = (g_194 x_196) + 20
+and g_194 n_195 = if n_195 = 0 then 1 else n_195 * (g_194 (n_195 - 1)) in
+((f_193 5), (g_194 5))>.
+# * * * * * * * * * * # * * * * * Characters 11-13:
+ .<let rec [] = [] in []>.
+ ^^
+Only variables are allowed as left-hand side of `let rec'
+# * * * * * Characters 11-16:
+ .<let rec f = f in f>.
+ ^^^^^
+Recursive let binding must be to a function
+# - : (int -> bool) code = .<
+fun x_203 ->
+ let rec even_204 = function | 0 -> true | x_207 -> odd_205 (x_207 - 1)
+ and odd_205 = function | 0 -> false | x_206 -> even_204 (x_206 - 1) in
+ even_204 x_203>.
+
+# * * * * * * # # - : int code = .<let x_218 = 1
+ and y_219 = 2 in x_218 + y_219>.
+# * * # - : int code = .<
+let x_222 = 1 in let x_223 = x_222 + 1
+ and y_224 = x_222 + 1 in x_223 + y_224>.
+
+# * * * # - : (int option -> int) code = .<
+fun x_228 -> let Some x_229 = x_228 in x_229 + 1>.
+# * * * * * * * * * # Exception: Match_failure ("//toplevel//", 831, -265).
+# * * Error was expected
+- : unit = ()
+# - : int code = .<1>.
+# - : int code = .<x_235>.
+
+Failure("The code built at Characters 63-64:\n let r = ref .<0>. in let _ = .<fun x -> .~(r := .<x>.; .<0>.)>. in !r ;;\n ^\n is not closed: identifier x_235 bound at Characters 63-64:\n let r = ref .<0>. in let _ = .<fun x -> .~(r := .<x>.; .<0>.)>. in !r ;;\n ^\n is free")
+# * * * * Error was expected
+- : unit = ()
+# Exception:
+Failure
+ "The code built at Characters 44-45:\n let c = let r = ref .<0>. in let _ = .<fun x -> .~(r := .<x>.; .<0>.)>. in (!r) in !. c;;\n ^\n is not closed: identifier x_236 bound at Characters 44-45:\n let c = let r = ref .<0>. in let _ = .<fun x -> .~(r := .<x>.; .<0>.)>. in (!r) in !. c;;\n ^\n is free".
+# * * * * Error was expected
+- : unit = ()
+# - : ('_a -> '_a) code = .<fun y_239 -> x_238>.
+
+Failure("The code built at Characters 58-68:\n let r = ref .<fun y->y>. in let _ = .<fun x -> .~(r := .<fun y -> x>.; .<0>.)>. in !r ;;\n ^^^^^^^^^^\n is not closed: identifier x_238 bound at Characters 43-44:\n let r = ref .<fun y->y>. in let _ = .<fun x -> .~(r := .<fun y -> x>.; .<0>.)>. in !r ;;\n ^\n is free")
+# * * * * * Error was expected
+- : unit = ()
+# Exception:
+Failure
+ "Scope extrusion detected at Characters 139-147:\n let _ = .<fun x -> .~(r := .<fun y -> x>.; .<0>.)>. in .<fun x -> .~(!r) 1>. ;;\n ^^^^^^^^\n for code built at Characters 102-112:\n let _ = .<fun x -> .~(r := .<fun y -> x>.; .<0>.)>. in .<fun x -> .~(!r) 1>. ;;\n ^^^^^^^^^^\n for the identifier x_241 bound at Characters 87-88:\n let _ = .<fun x -> .~(r := .<fun y -> x>.; .<0>.)>. in .<fun x -> .~(!r) 1>. ;;\n ^\n".
+# * * * * * Error was expected
+- : unit = ()
+# * * - : ('_a -> '_a) code = .<fun y_246 -> y_246>.
+# * * - : ('_a -> '_b -> '_b) code = .<fun x_248 -> fun y_249 -> y_249>.
+# * * - : ('_a -> '_a -> '_a) code = .<fun x_251 -> fun y_252 -> x_251>.
+# * * #
+All done
+
+- : unit = ()
+#
diff -Naur ocaml-4.02.1/metalib/trxtime.c ocaml-ber-n102/metalib/trxtime.c
--- ocaml-4.02.1/metalib/trxtime.c 1970-01-01 01:00:00.000000000 +0100
+++ ocaml-ber-n102/metalib/trxtime.c 2015-01-10 16:27:06.936030975 +0000
@@ -0,0 +1,67 @@
+/* More precise timing functions and CPU counters */
+
+#include "cycle.h" /* Get cycle counter, FFTW project */
+ /* http://www.fftw.org/download.html */
+
+/* The following is probablyu no longer needed: caml_sys_time
+ now uses rusage
+*/
+
+/* Return the structure of user and system process times, in whole
+ and fractional seconds.
+ sys_times:: unit -> double * double
+ Because we invoke caml_copy_double() function, which may cause gc(),
+ we must use CAMLparam/CAMLreturn() conventions.
+*/
+CAMLprim value sys_times(value unit)
+{
+ CAMLparam0 (); /* unit is unused */
+ struct rusage ru;
+ CAMLlocal3 (result, utime, stime);
+
+ memset(&ru,0,sizeof ru);
+ getrusage(0,&ru);
+ result = caml_alloc_small (2, 0);
+ utime = caml_copy_double((double)ru.ru_utime.tv_sec +
+ (double)ru.ru_utime.tv_usec/1000000.0);
+ stime = caml_copy_double((double)ru.ru_stime.tv_sec +
+ (double)ru.ru_stime.tv_usec/1000000.0);
+ Field(result, 0) = utime; /* Simple assignments don't cause GC */
+ Field(result, 1) = stime; /* We're overriding freshly allocated fields */
+ CAMLreturn (result);
+}
+
+/* Ticks is an abstract data type.
+ It means different things on different systems.
+ See cycle.h for more details.
+ */
+
+/*
+ Get the current ticks counter. Return an abstract value
+*/
+
+CAMLprim value sys_get_ticks(value unit)
+{
+ value res;
+ ticks t;
+ Assert(sizeof(t) == (sizeof t/sizeof res) * sizeof(res)); /* a constant op*/
+#define Setup_for_gc
+#define Restore_after_gc
+ Alloc_small(res, (sizeof t/sizeof res), Abstract_tag);
+#undef Setup_for_gc
+#undef Restore_after_gc
+ t = getticks();
+ memcpy(Bp_val(res),&t,sizeof t);
+ return res;
+}
+
+/*
+ * Return the difference between the current tick counter and the passed one.
+ */
+CAMLprim value sys_elapsed_ticks(value t0)
+{
+ /* no CAML memory allocation, except for the very end */
+ ticks tt0, tt1 = getticks();
+ memcpy(&tt0,Bp_val(t0),sizeof tt0);
+ return caml_copy_double(elapsed(tt1,tt0));
+}
diff -Naur ocaml-4.02.1/metalib/trxtime.ml ocaml-ber-n102/metalib/trxtime.ml
--- ocaml-4.02.1/metalib/trxtime.ml 1970-01-01 01:00:00.000000000 +0100
+++ ocaml-ber-n102/metalib/trxtime.ml 2015-01-10 16:27:06.936030975 +0000
@@ -0,0 +1,270 @@
+let print_buffer = ref []
+let numbers_buffer = ref []
+
+let init_times () =
+ let _ = print_buffer := [] in
+ numbers_buffer := []
+
+(* helper function to print times consisently *)
+
+let pt s reps elapsed =
+ let t = String.sub (s^" ___________________") 0 20 in
+ let reps_string = "_________ "^(string_of_int reps) in
+ let len = String.length reps_string in
+ let reps_trimed = String.sub reps_string (len-10) 10 in
+ let _ = numbers_buffer := (s, reps, elapsed) :: !numbers_buffer in
+ print_buffer := (fun () -> (Format.fprintf Format.std_formatter
+ "__ %s_%sx avg= %E msec"
+ t reps_trimed elapsed; (Format.print_newline ()))) :: !print_buffer
+
+(* do total time *)
+let time reps s f =
+ let initial = Sys.time() in
+ let _ = while initial = (Sys.time()) do () done in
+ let initial = Sys.time() in
+ let result = f () in
+ let final =
+ (for i=1 to reps-1 do f() done;
+ Sys.time ()) in
+ let elapsed = (final -. initial) *. 1000.0 /. (float reps) in
+ pt s reps elapsed;
+ result
+
+let timenew s f =
+ let mx = ref 0 in (* Variables for fine timing construction *)
+ let n = ref 0 in
+ let m = ref 0 in
+ let s1 = ref 0.0 in
+ let s2 = ref 0.0 in
+ let s3 = ref 0.0 in
+ let _ = m:=0 in
+ let _ = mx:=0 in
+ let _ = s2:= (0.0) in
+ let _ = s3:= (0.0) in
+
+ let reps = ref 1 in (* adaptive timing code *)
+ let tr = ref 0.0 in
+ let t1 = Sys.time() in
+ let t2 = begin while (Sys.time() = t1) do () done; Sys.time() end in
+ let r = f () in
+ let _ = (tr:=Sys.time()) in
+ let _ = while (!tr -. t2 < 1.0)
+ do for i=1 to !reps
+ do f () done;
+ reps := (!reps)*2;
+ tr := Sys.time ()
+ done in (* end adaptive timing code *)
+
+let _ = s1:= !tr in (* back to fine timing code *)
+let _ = for j=1 to 1 do
+ while (Sys.time () = (!s1)) do
+ for i=1 to 100 do
+ n := (!n) + 1
+ done
+ done; s2:=(Sys.time ())
+ done in
+let _ = s1:=!s2 in
+let _ = for j=1 to 10 do
+ while (Sys.time () = (!s2)) do
+ for i=1 to 100 do
+ m := (!m) + 1
+ done
+ done; s2:=(Sys.time ());
+ mx:= max !m !mx;
+ m:=0;
+ done; in
+let p = (float !n)/.(float !mx) in
+let te = (!tr*.(1.0-.p)) +. (!s1*.p) in
+
+ let dt = (te -. t2) in
+ let n = !reps in
+ let at = dt *. 1000.0 /. (float n) in
+ pt s n at;
+ r
+
+let print_times () =
+ List.iter (fun f -> f ()) (List.rev !print_buffer);
+ print_buffer := []
+
+let get_times () =
+ let nums = (List.rev !numbers_buffer) in
+ let _ = numbers_buffer := [] in
+ nums
+
+(* To be activated later
+
+(* More precise timing functions *)
+type ticks
+
+external times: unit -> float * float = "sys_times"
+external get_ticks: unit -> ticks = "sys_get_ticks"
+external elapsed_ticks: ticks -> float = "sys_elapsed_ticks"
+
+(** Timing based on CPU cycles.
+ CPU cycle counter is a real timer; it counts in CPU cycles, whose
+ period is the inverse of the rated frequency of the CPU.
+ The CPU cycle counter is most useful for shorter functions: for longer
+ functions, CPU cycle counter sees the effect of time interrupts and
+ preemption. Unlike the timing returned by Sys.time or
+ times, the cycle counter is real. That is, it counts even
+ when other process has the control of the CPU. CPU cycle counter
+ sees the effect of caching, etc.
+
+ See
+ http://cedar.intel.com/software/idap/media/pdf/rdtscpm1.pdf
+ for more details on cycle counter.
+
+ For consistency with the other timing interface, our function should
+ invoke 'pt s n at' and pass the number of invocations of the
+ function to time (n) and the elapsed time, in _milli_seconds.
+ Therefore, we have to deterimine the calibrartion coefficient from
+ cycles to seconds.
+
+ To avoid the interference from time interrupts and scheduler
+ pre-emptions, we repeat the timing measurements to make the elapsed
+ time last up to 9 milliseconds, assuming a 100 Hz scheduling clock.
+ We accumulate the count of all the executions of the functions and
+ return the second smallest. We do a few dry runs of the function to
+ warm up the caches.
+*)
+
+(* We target our cycle counters to last no more than the following number
+ of seconds.
+ The number is 90% of the scheduling interval (typically 10 ms).
+ It's quite likely that the current process will be preempted after
+ it consumes its quantum, and its priority lowered.
+*)
+let cycle_timing_target = 0.009
+
+
+(* Cycles to seconds calibration code.
+ get_cycles_per_second: () -> float
+ Return the number of cycles per second.
+*)
+
+let get_cycles_per_second () =
+ let calib_fn n = for i=1 to n do let _ = sin 0.8 in () done in
+ let repeat = 5 in (* How many times to repeat everything*)
+ let n_target = (* How many times to repeat calib_fn*)
+ let () = calib_fn 10 in (* warm up the cache *)
+ let rec loop n1 n2 =
+ let (tbeg,_) = times () in
+ let () = calib_fn n2 in
+ let exp = fst (times ()) -. tbeg in
+ if exp > cycle_timing_target then
+ if n1 = n2 then n1 else
+ if exp > 1.09 *. cycle_timing_target
+ then loop n1 ((n1 + n2)/2) else n2
+ else loop n2 (2*n2) in
+ loop 1000 1000
+ in
+ let do_cycles () =
+ let () = calib_fn 10 in (* warm up the cache *)
+ let cbeg = get_ticks () in
+ let () = calib_fn n_target in
+ elapsed_ticks cbeg
+ in
+ let do_times () =
+ let () = calib_fn 10 in (* warm up the cache *)
+ let (tbeg,_) = times () in
+ let () = calib_fn n_target in
+ fst (times ()) -. tbeg
+ in
+ let cycles_est = (* the second smallest datum *)
+ let d1 = do_cycles () in
+ let d2 = do_cycles () in
+ let rec loop d1 d2 n =
+ if n = 0 then d2 else
+ let d = do_cycles () in
+ if d < d1 then loop d d1 (n-1) else
+ if d < d2 then loop d1 d (n-1) else loop d1 d2 (n-1) in
+ loop (min d1 d2) (max d1 d2) repeat
+ in
+ let secs_est = (* the second smallest datum *)
+ let d1 = do_times () in
+ let d2 = do_times () in
+ let rec loop d1 d2 n =
+ if n = 0 then d2 else
+ let d = do_times () in
+ if d < d1 then loop d d1 (n-1) else
+ if d < d2 then loop d1 d (n-1) else loop d1 d2 (n-1) in
+ loop (min d1 d2) (max d1 d2) repeat
+ in
+ (* taking the second smallets datum for secs_est seems to give
+ more robust calibration coefficient, with smaller variance. Therefore,
+ the following averaging code is commented out. *)
+(* let secs_est1 = *)
+(* let rec loop accum n = *)
+(* if n = 0 then accum else *)
+(* loop (accum +. do_times ()) (n-1) *)
+(* in (loop 0.0 repeat) /. (float repeat) *)
+ cycles_est /. secs_est
+
+let cycles_per_second = ref 0.0
+
+(* execute function f reasonable number of times and obtain the timing
+ data, based on the cycles counter.
+ s is an identification string.
+ return the result of f.
+ We use the function "pt s n at" to record the timing info.
+ The last argument of pt is timing in _milliseconds_!
+ We try to run f as many times to be close to
+ cycle_timing_target as possible. It makes no sense
+ to run f() for longer intervals as we inevitably get scheduled out.
+*)
+
+let timecycles s f =
+ let () = if !cycles_per_second = 0.0 then
+ cycles_per_second := get_cycles_per_second () else () in
+ let rough_timing = (* in secs *)
+ let _ = f () in
+ let _ = f () in
+ let cbeg = get_ticks () in
+ let _ = f () in
+ (elapsed_ticks cbeg) /. !cycles_per_second in
+ let short_function = rough_timing < cycle_timing_target /. 50.0 in
+ let count_major = if short_function then
+ cycle_timing_target /. (5.0 *. rough_timing) else
+ cycle_timing_target /. rough_timing in
+ let count_major = max (int_of_float count_major) 5 in
+ let do_cycle f = (* the second smallest datum *)
+ if short_function then
+ let _ = f () in
+ let _ = f () in (* warm up the caches *)
+ let d1 = let cbeg = get_ticks () in
+ f(); f(); f(); f(); f(); elapsed_ticks cbeg in
+ let d2 = let cbeg = get_ticks () in
+ f(); f(); f(); f(); f(); elapsed_ticks cbeg in
+ let rec loop d1 d2 n =
+ if n = 0 then d2 else
+ let d = let cbeg = get_ticks () in
+ f(); f(); f(); f(); f(); elapsed_ticks cbeg in
+ if d < d1 then loop d d1 (n-1) else
+ if d < d2 then loop d1 d (n-1) else loop d1 d2 (n-1) in
+ loop (min d1 d2) (max d1 d2) (count_major-2)
+ else
+ let _ = f () in (* warm up the caches *)
+ let d1 = let cbeg = get_ticks () in f(); elapsed_ticks cbeg in
+ let d2 = let cbeg = get_ticks () in f(); elapsed_ticks cbeg in
+ let rec loop d1 d2 n =
+ if n = 0 then d2 else
+ let d = let cbeg = get_ticks () in f(); elapsed_ticks cbeg in
+ if d < d1 then loop d d1 (n-1) else
+ if d < d2 then loop d1 d (n-1) else loop d1 d2 (n-1) in
+ loop (min d1 d2) (max d1 d2) (count_major-2)
+ in
+ let result = f () in
+ let count_raw = do_cycle f in
+(*
+ let count_dummy = do_cycle (fun () -> ()) in
+ let count = if short_function then (count_raw -. count_dummy) /. 5.0
+ else (count_raw -. count_dummy) in
+*)
+ let count = if short_function then count_raw /. 5.0
+ else count_raw in
+ let () = pt s (if short_function then 5 else 1)
+ (1000.0 *. count /. !cycles_per_second) in
+ result
+;;
+
+*)
diff -Naur ocaml-4.02.1/metalib/trxtime.mli ocaml-ber-n102/metalib/trxtime.mli
--- ocaml-4.02.1/metalib/trxtime.mli 1970-01-01 01:00:00.000000000 +0100
+++ ocaml-ber-n102/metalib/trxtime.mli 2015-01-10 16:27:06.936030975 +0000
@@ -0,0 +1,34 @@
+(* time n s f executes f() n times and records message s plus elapsed time *)
+val time : int -> string -> (unit -> 'a) -> 'a
+val timenew : string -> (unit -> 'a) -> 'a
+val init_times : unit -> unit
+(* flushes recorded times *)
+val print_times : unit -> unit
+val get_times : unit -> ((string * int * float) list)
+
+(* To be activated later....
+
+(* More precise timing functions *)
+type ticks
+
+
+external times: unit -> float * float = "sys_times"
+(* returns user and system process times, in whole and fractional seconds.
+ Resolution upto a microsecond.
+ *)
+
+external get_ticks: unit -> ticks = "sys_get_ticks"
+(* Gets the CPU cycle counter as an abstract object. See cycle.h
+ from the FFTW project *)
+
+external elapsed_ticks: ticks -> float = "sys_elapsed_ticks"
+(* Returns the elapsed time in abstract units from the
+ specified moment till now. *)
+
+val timecycles: string -> (unit -> 'a) -> 'a
+(* like timenew but uses the CPU cycle counter for timing.
+ It's better for shorter functions that can run without being
+ scheduled out.
+*)
+
+*)
diff -Naur ocaml-4.02.1/parsing/lexer.mll ocaml-ber-n102/parsing/lexer.mll
--- ocaml-4.02.1/parsing/lexer.mll 2015-01-10 16:27:54.270865651 +0000
+++ ocaml-ber-n102/parsing/lexer.mll 2015-01-10 16:27:06.892032059 +0000
@@ -270,6 +270,8 @@
['A'-'Z' 'a'-'z' '_' '\192'-'\214' '\216'-'\246' '\248'-'\255' '\'' '0'-'9']
let symbolchar =
['!' '$' '%' '&' '*' '+' '-' '.' '/' ':' '<' '=' '>' '?' '@' '^' '|' '~']
+let symbolcharnodot = (* NNN *)
+ ['!' '$' '%' '&' '*' '+' '-' '/' ':' '<' '=' '>' '?' '@' '^' '|' '~'] (* NNN *)
let decimal_literal =
['0'-'9'] ['0'-'9' '_']*
let hex_literal =
@@ -302,6 +304,9 @@
}
| blank +
{ token lexbuf }
+ | ".<" { DOTLESS } (* NNN *)
+ | ">." { GREATERDOT } (* NNN *)
+ | ".~" { DOTTILDE } (* NNN *)
| "_"
{ UNDERSCORE }
| "~"
@@ -472,8 +477,10 @@
{ PREFIXOP(Lexing.lexeme lexbuf) }
| ['~' '?'] symbolchar +
{ PREFIXOP(Lexing.lexeme lexbuf) }
- | ['=' '<' '>' '|' '&' '$'] symbolchar *
+ | ['=' '<' '|' '&' '$'] symbolchar * (* NNN: ">." is not INFIXOP0 *)
{ INFIXOP0(Lexing.lexeme lexbuf) }
+ | ['>'] symbolcharnodot symbolchar * (* NNN exclude ">." case *)
+ { INFIXOP0(Lexing.lexeme lexbuf) } (* NNN *)
| ['@' '^'] symbolchar *
{ INFIXOP1(Lexing.lexeme lexbuf) }
| ['+' '-'] symbolchar *
@@ -483,6 +490,8 @@
| '%' { PERCENT }
| ['*' '/' '%'] symbolchar *
{ INFIXOP3(Lexing.lexeme lexbuf) }
+ | "let" symbolchar* (* NNN *)
+ { LETOP(Lexing.lexeme lexbuf) } (* NNN *)
| eof { EOF }
| _
{ raise (Error(Illegal_character (Lexing.lexeme_char lexbuf 0),
diff -Naur ocaml-4.02.1/parsing/parser.mly ocaml-ber-n102/parsing/parser.mly
--- ocaml-4.02.1/parsing/parser.mly 2015-01-10 16:27:54.270865651 +0000
+++ ocaml-ber-n102/parsing/parser.mly 2015-01-10 16:27:06.892032059 +0000
@@ -273,6 +273,21 @@
in
(exp, ghtyp(Ptyp_poly(newtypes,varify_constructors newtypes core_type)))
+ (* NNN: the whole definition *)
+let let_operator op bindings cont =
+ let pat, expr =
+ match bindings with
+ | [] -> assert false
+ | [x] -> (x.pvb_pat,x.pvb_expr)
+ | l ->
+ let pats, exprs =
+ List.fold_right
+ (fun {pvb_pat=p;pvb_expr=e} (ps,es) -> (p::ps,e::es)) l ([],[]) in
+ ghpat (Ppat_tuple pats), ghexp (Pexp_tuple exprs)
+ in
+ mkexp(Pexp_apply(op, [("", expr);
+ ("", ghexp(Pexp_fun("", None, pat, cont)))]))
+
let wrap_exp_attrs body (ext, attrs) =
(* todo: keep exact location for the entire attribute *)
let body = {body with pexp_attributes = attrs @ body.pexp_attributes} in
@@ -293,6 +308,9 @@
/* Tokens */
+%token DOTLESS /* NNN */
+%token GREATERDOT /* NNN */
+%token DOTTILDE /* NNN */
%token AMPERAMPER
%token AMPERSAND
%token AND
@@ -358,6 +376,7 @@
%token LESS
%token LESSMINUS
%token LET
+%token <string> LETOP /* NNN */
%token <string> LIDENT
%token LPAREN
%token LBRACKETAT
@@ -441,6 +460,7 @@
%nonassoc below_SEMI
%nonassoc SEMI /* below EQUAL ({lbl=...; lbl=...}) */
%nonassoc LET /* above SEMI ( ...; let ... in ...) */
+%nonassoc LETOP /* NNN */
%nonassoc below_WITH
%nonassoc FUNCTION WITH /* below BAR (match ... with ...) */
%nonassoc AND /* above WITH (module rec A: SIG with ... and ...) */
@@ -468,6 +488,7 @@
%nonassoc prec_unary_minus prec_unary_plus /* unary - */
%nonassoc prec_constant_constructor /* cf. simple_expr (C versus C x) */
%nonassoc prec_constr_appl /* above AS BAR COLONCOLON COMMA */
+%left prec_escape /* NNN */
%nonassoc below_SHARP
%nonassoc SHARP /* simple_expr/toplevel_directive */
%nonassoc below_DOT
@@ -1084,6 +1105,8 @@
{ mkexp(Pexp_apply($1, List.rev $2)) }
| LET ext_attributes rec_flag let_bindings_no_attrs IN seq_expr
{ mkexp_attrs (Pexp_let($3, List.rev $4, $6)) $2 }
+ | let_operator ext_attributes let_bindings IN seq_expr /* NNN */
+ { wrap_exp_attrs (let_operator $1 $3 $5) $2 } /* NNN */
| LET MODULE ext_attributes UIDENT module_binding_body IN seq_expr
{ mkexp_attrs (Pexp_letmodule(mkrhs $4 4, $5, $7)) $3 }
| LET OPEN override_flag ext_attributes mod_longident IN seq_expr
@@ -1200,6 +1223,12 @@
{ reloc_exp $2 }
| LPAREN seq_expr error
{ unclosed "(" 1 ")" 3 }
+ | DOTLESS expr GREATERDOT /* NNN */
+ { wrap_exp_attrs $2
+ (None,[ghloc "metaocaml.bracket",PStr []]) } /* NNN */
+ | DOTTILDE simple_expr %prec prec_escape /* NNN */
+ { wrap_exp_attrs $2
+ (None,[ghloc "metaocaml.escape",PStr []]) } /* NNN */
| BEGIN ext_attributes seq_expr END
{ wrap_exp_attrs (reloc_exp $3) $2 (* check location *) }
| BEGIN ext_attributes END
@@ -1961,6 +1990,7 @@
| INFIXOP2 { $1 }
| INFIXOP3 { $1 }
| INFIXOP4 { $1 }
+ | LETOP { $1 } /* NNN */
| BANG { "!" }
| PLUS { "+" }
| PLUSDOT { "+." }
@@ -1978,6 +2008,16 @@
| PLUSEQ { "+=" }
| PERCENT { "%" }
;
+ /* NNN: the whole definition */
+let_operator:
+ LETOP { mkexp (Pexp_ident(
+ mkloc (Lident $1)
+ (symbol_rloc ()))) }
+ | mod_longident DOT LETOP { mkexp (Pexp_ident(
+ mkloc (Ldot($1,$3))
+ (symbol_rloc ()))) }
+;
+
constr_ident:
UIDENT { $1 }
/* | LBRACKET RBRACKET { "[]" } */
diff -Naur ocaml-4.02.1/parsing/pprintast.ml ocaml-ber-n102/parsing/pprintast.ml
--- ocaml-4.02.1/parsing/pprintast.ml 2015-01-10 16:27:54.270865651 +0000
+++ ocaml-ber-n102/parsing/pprintast.ml 2015-01-10 16:27:06.896031960 +0000
@@ -47,6 +47,8 @@
let view_fixity_of_exp = function
| {pexp_desc = Pexp_ident {txt=Lident l;_};_} -> fixity_of_string l
+ | {pexp_desc = Pexp_ident {txt=Ldot (Lident "Pervasives",l);_};_} -> (*NNN*)
+ fixity_of_string l (*NNN*)
| _ -> `Normal ;;
let is_infix = function | `Infix _ -> true | _ -> false
@@ -512,11 +514,44 @@
end
| _ -> false
method expression f x =
- if x.pexp_attributes <> [] then begin
+ (* NNN begin *)
+ (* Keep in mind that there may be several metaocaml
+ attributes, and the order matters *)
+ (* Here we assume that all metaocaml attributes are at the front,
+ which is how they are generated.
+ *)
+ match x.pexp_attributes with
+ | ({txt="metaocaml.bracket"},_) :: t ->
+ pp f "@[<hov2>.<@ %a @ >.@]" self#expression {x with pexp_attributes=t}
+ | ({txt="metaocaml.escape"},_) :: t ->
+ begin
+ match x.pexp_desc with
+ | Pexp_ident li when t = [] -> pp f ".~%a" self#longident_loc li
+ | _ -> pp f ".~%a" (self#paren true self#expression)
+ {x with pexp_attributes=t}
+ end
+ | [({txt = "metaocaml.csp"},PStr [{pstr_desc =
+ Pstr_eval ({pexp_desc=Pexp_ident li},_)}])] ->
+ begin
+ (* This CSP is easy to print, so we print it *)
+ match x.pexp_desc with
+ | Pexp_apply (_,[("",{pexp_desc=Pexp_constant (Const_int _)})])
+ ->
+ pp f "(* CSP %a *) %a"
+ self#longident_loc li
+ self#expression {x with pexp_attributes=[]}
+ | _ ->
+ pp f "(* CSP %a *)"
+ self#longident_loc li
+ end
+ (* if x.pexp_attributes <> [] then begin *)
+ | _::_ ->
pp f "((%a)%a)" self#expression {x with pexp_attributes=[]}
self#attributes x.pexp_attributes
- end
- else match x.pexp_desc with
+ (* end *)
+ | _ -> begin match x.pexp_desc with
+ (* else match x.pexp_desc with *)
+ (* NNN end *)
| Pexp_function _ | Pexp_fun _ | Pexp_match _ | Pexp_try _ | Pexp_sequence _
when pipe || semi ->
self#paren true self#reset#expression f x
@@ -620,6 +655,7 @@
pp f "@[<2>`%s@;%a@]" l self#simple_expr eo
| Pexp_extension e -> self#extension f e
| _ -> self#expression1 f x
+ end (* NNN *)
method expression1 f x =
if x.pexp_attributes <> [] then self#expression f x
else match x.pexp_desc with
diff -Naur ocaml-4.02.1/typing/predef.ml ocaml-ber-n102/typing/predef.ml
--- ocaml-4.02.1/typing/predef.ml 2015-01-10 16:27:54.270865651 +0000
+++ ocaml-ber-n102/typing/predef.ml 2015-01-10 16:27:06.932031073 +0000
@@ -120,6 +120,17 @@
and ident_cons = ident_create "::"
and ident_none = ident_create "None"
and ident_some = ident_create "Some"
+
+(* NNN ident_create "code" must be placed at the end of all other
+ ident creation expressions, to make sure that creating ident_code
+ does not shift the timestamps of other standard idents like
+ Eof, etc. Otherwise, binary compatibility with OCaml breaks,
+ and we have to do the expensive bootstrapping.
+*)
+let ident_code = ident_create "code" (* NNN *)
+let path_code = Pident ident_code (* NNN *)
+let type_code t = newgenty (Tconstr(path_code, [t], ref Mnil)) (* NNN *)
+
let common_initial_env add_type add_extension empty_env =
let decl_bool =
{decl_abstr with
@@ -157,6 +168,13 @@
type_params = [tvar];
type_arity = 1;
type_variance = [Variance.covariant]}
+ (* NNN added decl_code *)
+ and decl_code =
+ let tvar = newgenvar() in
+ {decl_abstr with
+ type_params = [tvar];
+ type_arity = 1;
+ type_variance = [Variance.covariant]}
in
let add_extension id l =
@@ -184,6 +202,7 @@
[newgenty (Ttuple[type_string; type_int; type_int])] (
add_extension ident_undefined_recursive_module
[newgenty (Ttuple[type_string; type_int; type_int])] (
+ add_type ident_code decl_code ( (* NNN *)
add_type ident_int64 decl_abstr (
add_type ident_int32 decl_abstr (
add_type ident_nativeint decl_abstr (
@@ -198,7 +217,8 @@
add_type ident_string decl_abstr (
add_type ident_char decl_abstr (
add_type ident_int decl_abstr (
- empty_env))))))))))))))))))))))))))
+ empty_env)))))))))))))))))))))))))) ) (* NNN extra parenthesis *)
+
let build_initial_env add_type add_exception empty_env =
let common = common_initial_env add_type add_exception empty_env in
diff -Naur ocaml-4.02.1/typing/predef.mli ocaml-ber-n102/typing/predef.mli
--- ocaml-4.02.1/typing/predef.mli 2015-01-10 16:27:54.270865651 +0000
+++ ocaml-ber-n102/typing/predef.mli 2015-01-10 16:27:06.932031073 +0000
@@ -29,6 +29,7 @@
val type_int32: type_expr
val type_int64: type_expr
val type_lazy_t: type_expr -> type_expr
+val type_code: type_expr -> type_expr (* NNN *)
val path_int: Path.t
val path_char: Path.t
@@ -45,6 +46,7 @@
val path_int32: Path.t
val path_int64: Path.t
val path_lazy_t: Path.t
+val path_code: Path.t (* NNN *)
val path_match_failure: Path.t
val path_assert_failure : Path.t
diff -Naur ocaml-4.02.1/typing/trx.ml ocaml-ber-n102/typing/trx.ml
--- ocaml-4.02.1/typing/trx.ml 1970-01-01 01:00:00.000000000 +0100
+++ ocaml-ber-n102/typing/trx.ml 2015-01-10 16:27:06.932031073 +0000
@@ -0,0 +1,2398 @@
+(*
+ This file is to post-process the Typedtree built by the type checker
+ when it finished parsing the present-stage bracket expression.
+ (Unlike versions before N102, the full Typedtree is not traversed;
+ only the bracket expressions are traversed and lifted.) The
+ transformation is done by trx_bracket.
+
+ For example,
+ <succ 1>
+ gets transformed to
+ mkApp <succ> <1>
+ and eventually to
+ mkApp (mkIdent "succ") (mkConst 1)
+ One may say that we `push the brackets inside'. We replace brackets
+ with calls to functions that will construct, at run-time, a
+ Parsetree, which is the representation of values of the code type.
+
+ Generally, the Parsetree is constructed when the program is run.
+ In some cases we can construct the Parsetree at compile time,
+ that is, when this trx.ml is run. Constants like <1> is such a case.
+ If we see <1>, or, in terms of trees,
+ Texp_bracket (Texp_constant (Constant_int 1))
+ we can immediately construct the Parsetree:
+ Pexp_constant (Constant_int 1)
+ After we construct the Parsetree at compile time, we use CSP to
+ pass it over to run-time. At run-time, we merely use the compiled constant.
+ This mechanism of building Parsetree at compile-time whenever possible
+ is one of the large differences from the previous versions of MetaOCaml.
+
+ Future-stage Bindings.
+ Future-stage bindings are introduced by patterns in let, fun,
+ match, try and for forms. Global bindings are always at present-stage.
+ Since local modules in brackets are not allowed, all future bindings are
+ unqualified (i.e., simple names, without the module path).
+ The principal rule of translating binding forms is
+ <fun x -> e> ---> let x = gensym "x" in mkLAM x <e>
+ Emphatically, gensym cannot be run at compile time!
+ Reason: consider the recursive invocation:
+ let rec f z = <fun y -> ~( ... f 1 ... )>
+
+ Thus, at run-time, we generate new names for bound variables and
+ use the OCaml's evaluator (the `run-time') to substitute these
+ new names in <e>. Therefore, a future-stage bound variable after
+ the translation becomes a present-stage bound variable,
+ but at a different type: string loc. We use string loc rather
+ than Longident.t loc since all, at present, future-stage bindings
+ are simple names.
+
+ We now check for scope extrusion: we enforce the region discipline
+ for generated identifiers. To make it easier to impose checks,
+ the translation rule is modified as follows
+ <fun x -> e> ---> build_simple_fun "x" (fun x -> <e>)
+ One can say that <fun x -> e> of the type (a->b) code is translated
+ into (fun x -> <e>) of the type a code -> b code. This looks quite
+ like the HOAS syntax for lambda (see the code-generation approach
+ with code combinators. The function build_simple_fun generates a gensym
+ and establishes a region for the gensym variable.
+
+ OCaml has more complicated functions, <function pattern -> body> with
+ complex patterns. If the patterns contain no binding variables,
+ there is no need to go into the gensym generation. The translation is
+ no more complex than that of <lazy e>.
+ For more complicated binding patterns, we generalize, for example
+ <fun (x1,true,x2) as x3 -> e1 | _ -> e2> --->
+ build_fun ["x1";"x2"] (fun (x1,x2,x3) -> [<e1>;e2])
+ That is, we pick all binding variables from the pattern and build a
+ function that receives the code for these variables and produces the
+ array of code for all alternatives.
+
+ Here are the main patterns of scope extrusion
+ let r = <0> in
+ <fun x -> ~(r := <x + 1>; <()>)>
+
+ let r = <0> in
+ <fun x -> .~(<fun x -> ~(let v = <x> in r := <fun x -> ~v>; <()>)>; !r)>
+
+ exception E of int code
+ try <fun x -> ~(raise (E <x>)> with E x -> x
+ (actually we need a local polymorphic exception, but the idea is the same)
+
+ and similar using control effects.
+
+ The most obvious method of detecting the scope extrusion is traversing
+ the generated code looking for unbound identifiers. We can do
+ such a check when we are about to show or run the code, or
+ about to splice (in the latter case, we have to maintain
+ the dynamic environment of gensym'ed names generated by
+ build_fun_). However, reporting the scope
+ extrusion upon printing or running the code is reporting it too
+ late. Doing the check on each escape (since only splices can incorporate
+ scope-extruded code) means many repeated traversals of the generated
+ code.
+
+ We use a different method: we mark each piece of the generated code
+ with the list of free variable the code contains. Each variable
+ is associated with a `stackmark', which identifiers the region
+ with which the variable is associated. All valid stackmarks form
+ a total order. Alas, delimited control can reshuffle that order.
+ The function build_simple_fun and others enter a new region
+ and then check that the generated body contains only valid stackmarks
+ (that is, stackmarks that correspond to active regions).
+ Every code building function ( build_* ) checks to see that the stackmarks
+ in the incorporated fragments are all valid, that is,
+ correspond currently alive variables. These code building function
+ merge the free variable lists (heaps actually) from the incorporated
+ fragments.
+
+This file was based on trx.ml from the original MetaOCaml, but it is
+completely re-written from scratch and has many comments. The
+traversal algorithm, the way of compiling Parsetree builders, dealing
+ with CSP and many other algorithms are all different.
+
+*)
+
+open Parsetree
+open Asttypes
+open Typedtree
+open Types
+
+
+(*{{{ Preliminaries, common functions *)
+
+(* BER MetaOCaml version string *)
+let meta_version = "N 102"
+
+(* Co-opt the Preprocessor class of warnings *)
+let debug_print ?(loc = Location.none) : string -> unit = fun msg ->
+ Location.prerr_warning loc (Warnings.Preprocessor msg)
+
+(* Emit a translation-time error *)
+exception Error of Location.error
+
+let trx_error loc_err = raise @@ Error loc_err
+
+let () =
+ Location.register_error_of_exn
+ (function
+ | Error err -> Some err
+ | _ -> None
+ )
+
+let not_supported loc msg =
+ trx_error @@ Location.errorf ~loc
+ "%s is not yet supported within brackets" msg
+
+(* left-to-right accumulating map *)
+let rec map_accum : ('accum -> 'a -> 'b * 'accum) -> 'accum -> 'a list ->
+ 'b list * 'accum = fun f acc -> function
+ | [] -> ([],acc)
+ | h::t ->
+ let (h,acc) = f acc h in
+ let (t,acc) = map_accum f acc t in
+ (h::t, acc)
+
+let initial_env = Env.initial_safe_string
+
+(* Attributes *)
+(* In a Parsetree, brackets, escape and CSPs are attributes on
+ the corresponding nodes.
+*)
+
+let attr_bracket = (Location.mknoloc "metaocaml.bracket",PStr [])
+
+let attr_escape = (Location.mknoloc "metaocaml.escape",PStr [])
+
+let rec get_attr : string -> attributes -> Parsetree.structure option =
+ fun name -> function
+ | [] -> None
+ | ({txt = n}, PStr str) :: _ when n = name -> Some str
+ | _ :: t -> get_attr name t
+
+let attr_csp : Longident.t loc -> attribute = fun lid ->
+ (Location.mknoloc "metaocaml.csp",PStr [
+ Ast_helper.Str.eval (Ast_helper.Exp.ident lid)])
+
+(* If the attribute is present, the expression is non-expansive
+ We use physical equality comparison, to speed things up
+*)
+let attr_nonexpansive : attribute =
+ (Location.mknoloc "metaocaml.nonexpansive",PStr [])
+
+
+(* The result of what_stage_attr *)
+type stage_attr_elim =
+ | Stage0
+ | Bracket of attribute * (* bracket attribute *)
+ attributes (* other attributes *)
+ | Escape of attribute * (* escape attribute *)
+ attributes (* other attributes *)
+ | CSP of attribute * Longident.t loc * (* CSP attribute and lid *)
+ attributes (* other attributes *)
+
+(* Determining if an AST node bears a staging attribute *)
+let what_stage_attr : attributes -> stage_attr_elim =
+ let rec loop acc = function
+ | [] -> Stage0
+ | (({txt = "metaocaml.bracket"},_) as a) :: t ->
+ Bracket (a,acc @ t)
+ | (({txt = "metaocaml.escape"},_) as a) :: t ->
+ Escape (a,acc @ t)
+ | (({txt = "metaocaml.csp"},PStr [{pstr_desc =
+ Pstr_eval ({pexp_desc=Pexp_ident lid},_)}]) as a) :: t ->
+ CSP (a,lid,acc @ t)
+ | a :: t -> loop (a::acc) t
+ in loop []
+
+(* Staging level
+ It is set via an attribute on the value_description in the Typedtree
+*)
+type stage = int (* staging level *)
+
+let attr_level n =
+ (Location.mknoloc "metaocaml.level",PStr [
+ Ast_helper.Str.eval (Ast_helper.Exp.constant (Const_int n))])
+
+let get_level : Parsetree.attributes -> stage = fun attrs ->
+ match get_attr "metaocaml.level" attrs with
+ | None -> 0
+ | Some [{pstr_desc =
+ Pstr_eval ({pexp_desc=Pexp_constant (Const_int n)},_)}] ->
+ assert (n>=0); n
+ | _ -> assert false (* Invalid level attribute *)
+
+
+(* In a Typedtree, <e> is represented as a sequence
+ begin 0; e end
+ again, with the corresponding attribute.
+ I chose 0 rather than () because if we forget to handle
+ bracket/escape properly, we get a warning. Still, begin 0; e end
+ is syntactically and type-correct .
+ Ditto for Escape.
+*)
+
+(*}}}*)
+
+
+(*{{{ Path and location utilities *)
+
+(* ------------------------------------------------------------------------ *)
+(* Path utilities *)
+
+(* We always use path when available, and convert it to Longident
+ when needed -- even if the Typedtree already carries the longident.
+ The path is preferred because it is fully qualified for
+ external identifiers and it is unambiguous.
+ If we open a module, its components can be referred to without
+ qualification -- the path will be qualified nevertheless.
+ When we build a Parsetree representing the generated code,
+ we have to use fully qualified identifiers since the open statement
+ in the original code won't be represented in the generated
+ Parsetree.
+*)
+
+(* Check to see if a path refers to an identifier, exception, or
+ constructor that is available from an external module. If so, the run-time
+ compiler invoked by run can get the definition for the identifier from
+ a .cmi file. The value of an external identifier can be obtained from
+ a .cmo file.
+ If a path contains several components like
+ M1.M2.M3.ident, we should check if the top-most component, that is, M1,
+ is external.
+*)
+(* XXX call Env.normalize_path first? *)
+
+let rec is_external = function
+ | Path.Pident id -> (* not qualified *)
+ Ident.persistent id || Ident.global id || Ident.is_predef_exn id
+ | Path.Papply _ -> false
+ | Path.Pdot(p, _,_) -> is_external p
+
+(* Convert a path to an identifier. Since the path is assumed to be
+ `global', time stamps don't matter and we can use just strings.
+*)
+let rec path_to_lid : Path.t -> Longident.t = function
+ | Path.Pident i -> Longident.Lident (Ident.name i)
+ | Path.Pdot (p,s,_) -> Longident.Ldot (path_to_lid p, s)
+ | Path.Papply (p1,p2) ->
+ Longident.Lapply(path_to_lid p1, path_to_lid p2)
+
+(* Convert the path to lid but use the given str as the last component.
+ This in effect qualifies 'str' with the given module path
+*)
+let path_to_lid_but_last : Path.t -> string -> Longident.t =
+ fun p str ->
+ match p with
+ | Path.Pident _ -> Longident.Lident str
+ | Path.Pdot (p,_,pos) -> path_to_lid (Path.Pdot (p,str,pos))
+ | _ -> assert false
+
+(* Replace the last component of p1 with p2, which should be a Pident
+ path
+*)
+let path_replace_last : Path.t -> Path.t -> Path.t = fun p1 p2 ->
+ match (p1,p2) with
+ | (Path.Pident _,x) -> x
+ | (Path.Pdot(p1,_,s),Path.Pident id) -> Path.Pdot(p1,Ident.name id,s)
+ | _ -> assert false
+
+
+(* Check to make sure a constructor, label, exception, etc.
+ have the name that we can put into AST (Parsetree).
+ Local names can't be put into the Parsetree since the type env in which
+ they are declared is not represented in the Parsetree.
+*)
+let check_path_quotable msg path =
+ if not (is_external path) then
+ trx_error @@ Location.errorf
+ "%s %s cannot be used within brackets. Put into a separate file."
+ msg (Path.name path)
+
+
+(* Check to see that a constructor belongs to a type defined
+ in a persistent module or in the initial environment.
+ Return the fully qualified name to put into AST
+ (Pervasive constructors remain unqualified however).
+
+ We have nothing to do if the constructor is already fully qualified
+ with a persistent module identifier: for example, Scanf.Scan_failure.
+ The major complexity comes from this scenario:
+ open Scanf
+ .<raise (Scan_failure "xx")>.
+ The Texp_construct node of Typedtree contains the lid and (was: the
+ path) that refer to "Scan_failure" without any module qualifications.
+ We have to find the fully qualified path and check
+ that it is external. We do that by finding the path for the _type_
+ constructor, for the type of which the data constructor is a member.
+ That type_path is fully qualified. We can ascertain the later fact
+ from Env.constructors_of_type, which puts the complete path
+ into the type of the constructor, which is always of the form
+ Tconstr(ty_path,_,_). The function constructors_of_type is used
+ within Env.store_type, which is used when opening a module.
+
+ Alternatively we could've used Env.lookup_constructor, which also
+ returns the qualified path? Searching the environment is costly
+ though.
+ Actually, using Env.lookup_constructor is a bad idea. Now labels and
+ constructors don;t have to be unique. The type checker goes to
+ a great length to disambiguate a constructor or a label. It records
+ the eventually determined type of the label/constructor in
+ label_description or constructor_description.
+ So, we should only use information from these descriptions.
+
+ Alas, the predefined types (with no module qualification) are
+ not specially distinguished. So, we have to check the initial
+ environment.
+ *)
+let qualify_ctor :
+ Longident.t loc -> constructor_description -> Longident.t loc =
+ fun lid cdesc ->
+ let loc = lid.loc in
+ match (cdesc.cstr_tag, Ctype.repr cdesc.cstr_res) with
+ | (Cstr_extension (p,_),_) ->
+ if is_external p then Location.mkloc (path_to_lid p) loc else
+ trx_error @@ Location.errorf ~loc
+ "Exception (extension) %s cannot be used within brackets. Put into a separate file."
+ (Path.name p)
+ | (_,{desc = Tconstr((Path.Pident _ as ty_path), _, _)}) ->
+ begin
+ try ignore (Env.find_type ty_path initial_env); lid
+ with Not_found ->
+ trx_error @@ Location.errorf ~loc
+ "Unqualified constructor %s cannot be used within brackets. Put into a separate file."
+ cdesc.cstr_name
+ end
+ | (_,{desc = Tconstr(ty_path, _, _)}) ->
+ if is_external ty_path then
+ Location.mkloc (path_to_lid_but_last ty_path cdesc.cstr_name) loc
+ else
+ trx_error @@ Location.errorf ~loc
+ "Constructor %s cannot be used within brackets. Put into a separate file."
+ cdesc.cstr_name
+ | _ -> Printtyp.type_expr Format.err_formatter cdesc.cstr_res;
+ failwith ("qualify_ctor: cannot determine type_ctor from data_ctor "^
+ cdesc.cstr_name)
+
+(* Check to see that a record label belongs to a record defined
+ in a persistent module or in the initial environment.
+ This is a label version of qualify_ctor
+*)
+let qualify_label : Longident.t loc -> label_description -> Longident.t loc =
+ fun lid ldesc ->
+ let loc = lid.loc in
+ match Ctype.repr ldesc.lbl_res with
+ | {desc = Tconstr((Path.Pident _ as ty_path), _, _)} ->
+ begin
+ try ignore (Env.find_type ty_path initial_env); lid
+ with Not_found ->
+ trx_error @@ Location.errorf ~loc
+ "Unqualified label %s cannot be used within brackets. Put into a separate file."
+ ldesc.lbl_name
+ end
+ | {desc = Tconstr(ty_path, _, _)} ->
+ if is_external ty_path then
+ Location.mkloc
+ (path_to_lid_but_last ty_path ldesc.lbl_name) loc
+ else
+ trx_error @@ Location.errorf ~loc
+ "Label %s cannot be used within brackets. Put into a separate file."
+ ldesc.lbl_name
+ | _ -> Printtyp.type_expr Format.err_formatter ldesc.lbl_res;
+ failwith ("qualify_label: cannot determine type from label "^
+ ldesc.lbl_name)
+
+(* Test if we should refer to a CSP value by name rather than by
+ value
+*)
+(* Module identifiers for the modules that are expected to be
+ present at run-time -- that is, will be available for
+ dynamic linking of the run-time generated code.
+
+TODO: check bytecomp/transclass.ml:const_path
+Perhaps that's a hint which unqualified identifiers will be persistent
+*)
+
+let ident_can_be_quoted = is_external
+
+(*}}}*)
+
+
+(*{{{ Templates for building Parsetree/Typedtree components *)
+
+(* Local reference: trx.cmi is available but location.cmi is not
+ necessarily is in the current path.
+*)
+let loc_none = Location.none
+
+let dummy_lid : string -> Longident.t loc = fun name ->
+ Location.mknoloc (Longident.Lident name)
+
+(* Exported. Used as a template for constructing lid expressions *)
+let sample_lid = dummy_lid "*sample*"
+
+(* Exported. Used as a template for constructing name expression *)
+let sample_name : string loc = mknoloc "*sample*"
+
+(* Exported. Used as a template for constructing pattern lists expressions *)
+let sample_pat_list : Parsetree.pattern list = []
+let sample_pats_names : Parsetree.pattern list * string loc list = ([],[])
+
+(*}}}*)
+
+
+(* ------------------------------------------------------------------------ *)
+(* Building Texp nodes *)
+(* initial_env is used for all look-ups. Unqualified identifiers
+ must be found there. For qualified identifiers, Env.lookup
+ functions look things up in the persistent structures, loading them
+ up as needed.
+*)
+
+let mk_texp : ?env:Env.t -> ?attrs:Parsetree.attributes ->
+ ?loc:Location.t ->
+ Typedtree.expression_desc -> type_expr ->
+ Typedtree.expression =
+ fun ?(env=initial_env) ?(attrs=[]) ?(loc=Location.none) desc ty ->
+ { exp_desc = desc; exp_type = ty;
+ exp_loc = loc; exp_extra = [];
+ exp_attributes = attrs;
+ exp_env = env }
+
+let texp_int : int -> Typedtree.expression = fun n ->
+ mk_texp ~env:Env.initial_safe_string (Texp_constant (Const_int n))
+ (Ctype.instance_def Predef.type_int)
+
+(* Make a bracket or an escape node
+ Here, the attr argument is a bracket/escape attribute
+*)
+let texp_zero = (* TExp node for constant 0 *)
+ texp_int 0
+
+let texp_braesc :
+ attribute -> Typedtree.expression -> Env.t -> type_expr ->
+ Typedtree.expression =
+ fun attr exp env ty ->
+ mk_texp ~env ~attrs:(attr :: exp.exp_attributes)
+ ~loc:exp.exp_loc (Texp_sequence (texp_zero, exp)) ty
+
+
+(* A CSP is in essence a constant. So, we represent CSP as a constant,
+ with an annotation that contains the name of the identifier
+ *)
+
+let texp_csp_raw :
+ attribute -> Asttypes.constant -> Env.t -> type_expr -> Typedtree.expression =
+ fun attr cnt env ty ->
+ {
+ exp_desc = Texp_constant cnt;
+ exp_loc = Location.none; exp_extra = [];
+ exp_type = ty;
+ exp_attributes = [attr];
+ exp_env = env }
+
+
+(* TODO: add memoization? *)
+
+(* Compiling an identifier with a given (qualified) name *)
+let texp_ident : string -> expression = fun name ->
+ let lid = Longident.parse name in
+ let (p, vd) = try Env.lookup_value lid initial_env
+ with Not_found ->
+ Misc.fatal_error ("Trx.find_value: " ^ name) in
+ mk_texp (Texp_ident (p,mknoloc lid, vd))
+ (Ctype.instance initial_env vd.val_type)
+
+
+(* Building an application *)
+let texp_apply : Typedtree.expression -> Typedtree.expression list ->
+ Typedtree.expression_desc = fun f args ->
+ Texp_apply(f, List.map (fun arg -> ("",Some arg, Required)) args)
+
+(* Compiling a string constant *)
+(* The second argument of Const_string is the delimiter,
+ the decorator in the {decorator| ... |decorator} notation.
+*)
+let texp_string : string -> Typedtree.expression = fun str ->
+ mk_texp (Texp_constant (Const_string (str,None)))
+ (Ctype.instance_def Predef.type_string)
+
+(* Compiling a boolean *)
+(* For prototype, see Typecore.option_none *)
+let texp_bool : bool -> Typedtree.expression = fun b ->
+ let lid = Longident.Lident (if b then "true" else "false") in
+ let cdec = Env.lookup_constructor lid initial_env in
+ mk_texp (Texp_construct(mknoloc lid, cdec, []))
+ (Ctype.instance_def Predef.type_bool)
+
+(* Given a value v, create a Typedtree node for an expression
+ that will evaluate to v.
+ This the the CSP used by the MetaOCaml itself.
+ Since this is an internal CSP, we don't put any attributes.
+*)
+let texp_csp : Obj.t -> Typedtree.expression = fun v ->
+ if Obj.is_int v then texp_int (Obj.obj v)
+ (* We treat strings and bytes identically *)
+ else if Obj.tag v = Obj.string_tag then texp_string (Obj.obj v)
+ else
+ let vstr = Marshal.to_string v [] in
+ let () = if false then debug_print ("texp_csp, marshall: size " ^
+ string_of_int (String.length vstr)) in
+ mk_texp
+ (texp_apply (texp_ident "Marshal.from_string")
+ [texp_string vstr; texp_zero])
+ (Btype.newgenvar ())
+
+
+(* Compiling location data *)
+(* We could have made texp_loc an alias to texp_csp... We keep the
+ type information for location though, just to be fully correct.
+*)
+let texp_loc : Location.t -> Typedtree.expression = fun loc ->
+ let loc_exp = texp_ident "Trx.loc_none" in (* this fills in the type, etc.*)
+ if loc == Location.none then loc_exp else
+ {loc_exp with exp_desc = (texp_csp (Obj.repr loc)).exp_desc}
+
+(* Compiling longident with location data *)
+let texp_lid : Longident.t loc -> Typedtree.expression = fun lid ->
+ let lid_exp = texp_ident "Trx.sample_lid" in (* this fills in the type, etc.*)
+ {lid_exp with exp_desc = (texp_csp (Obj.repr lid)).exp_desc}
+
+(* Compiling a string with a location *)
+let texp_string_loc : string loc -> Typedtree.expression = fun name ->
+ let name_exp = texp_ident "Trx.sample_name" in
+ {name_exp with
+ exp_desc = (texp_csp (Obj.repr name)).exp_desc}
+
+(* Compiling an option *)
+(* For prototype, see Typecore.option_none *)
+let texp_option : Typedtree.expression option -> Typedtree.expression =
+ function
+ | None ->
+ let lid = Longident.Lident "None" in
+ let cnone = Env.lookup_constructor lid initial_env in
+ mk_texp (Texp_construct(mknoloc lid, cnone, []))
+ (Ctype.instance_def (Predef.type_option (Btype.newgenvar ())))
+ | Some e ->
+ let lid = Longident.Lident "Some" in
+ let csome = Env.lookup_constructor lid initial_env in
+ mk_texp (Texp_construct(mknoloc lid, csome, [e]))
+ (Ctype.instance_def (Predef.type_option e.exp_type))
+ ~env:e.exp_env
+
+(* Compiling a tuple *)
+let texp_tuple : Typedtree.expression list -> Typedtree.expression = fun el ->
+ mk_texp (Texp_tuple el)
+ (Ctype.newty (Ttuple (List.map (fun e -> e.exp_type) el)))
+
+(* Compiling an array *)
+(* We use this function for grouping trx_bracket-transformed expressions,
+ which have the same representation type (but may be different
+ code type). We ignore the differences in the code type, since
+ the representation type is the same.
+
+ We don't use lists since they are harder to compile, and more
+ fragile. Texp_construct has more arguments, we have to locate
+ constructor information, etc.
+*)
+let texp_array : Typedtree.expression list -> Typedtree.expression = function
+ | [] ->
+ mk_texp (Texp_array [])
+ (Ctype.instance_def (Predef.type_array (Btype.newgenvar ())))
+ | (h::_) as el ->
+ mk_texp (Texp_array el)
+ (Ctype.instance_def (Predef.type_array h.exp_type))
+
+(* Compiling patterns and the list of names bound by them *)
+let texp_pats_names : Parsetree.pattern list -> string loc list ->
+ Typedtree.expression = fun pats names ->
+ let pn_exp = texp_ident "Trx.sample_pats_names" in
+ {pn_exp with
+ exp_desc = (texp_csp (Obj.repr (pats,names))).exp_desc}
+
+(* Utility function to build the case list *)
+let texp_case : ?guard:expression -> pattern -> expression -> case =
+ fun ?guard pat exp ->
+ {c_lhs=pat; c_guard=guard; c_rhs=exp}
+
+(* ------------------------------------------------------------------------ *)
+(* Stack marks, a simple form of dynamic binding *)
+
+(* In the earlier version, our stackmarks could be ordered.
+ Alas, it is hard to dynamically replace the implementation
+ below with the one adjusted for delimcc. The implementation below
+ does not work when partial continuations can be captured and reinstated.
+ Mainly, when delimited continuations are used, the order is
+ not stable. Delimited control operators can reshuffle the order
+ arbitrarily. Therefore, the fact that there is order among valid stackmarks
+ is not helpful anyway.
+
+module type STACKMARK = sig
+ type t
+ val is_valid : t -> bool
+ (* compare is supposed to be called on stack marks that are
+ checked to be valid
+ *)
+ val compare : t -> t -> int
+ val with_stack_mark : (t -> 'w) -> 'w
+end
+
+(* Simple implementation with shallow dynamic binding *)
+module StackMark : STACKMARK = struct
+ type t = int ref
+
+ (* The global counter of the nesting depth of with_stack_mark *)
+ let stack_mark_cnt = ref 0
+
+ (* A stack mark is ref n where n is the depth of the corresponding
+ with_stack_mark form.
+ The stack mark is invalid if the counter is 0
+ *)
+ let with_stack_mark body =
+ incr stack_mark_cnt;
+ let mark = ref !stack_mark_cnt in
+ let finalize () =
+ mark := 0; (* invalidate the mark *)
+ assert (!stack_mark_cnt > 0);
+ decr stack_mark_cnt
+ in
+ try
+ let r = body mark in finalize (); r
+ with e -> finalize (); raise e
+
+ let is_valid mark = !mark > 0
+ let compare m1 m2 =
+ assert (!m1 >0 && !m2 > 0);
+ compare !m1 !m2
+end
+
+*)
+
+(* A robust and truly minimalistic implementation of stack-marks.
+ A stack-mark is created by 'with_stack_mark' function. Since
+ the only operation on a stackmark is to test if it is valid,
+ the stackmark is realized as a thunk unit -> bool.
+*)
+type stackmark = unit -> bool (* true if valid *)
+
+(* The type of the with_stack_mark operation *)
+type stackmark_region_fn =
+ {stackmark_region_fn : 'w. (stackmark -> 'w) -> 'w}
+
+(* The simple implementation of stackmark_region_fn, appropriate
+ when no delimited control is used.
+ The mark is a ref bool cell, containing true within
+ stackmark_region_fn's dynamic region.
+*)
+let with_stack_mark_simple : stackmark_region_fn =
+ {stackmark_region_fn = fun body ->
+ let mark = ref true in
+ try
+ let r = body (fun () -> !mark) in
+ mark := false; (* invalidate the mark *)
+ r
+ with e -> mark := false; raise e
+ }
+
+let with_stack_mark : stackmark_region_fn ref = ref with_stack_mark_simple
+
+(* Replace a with_stack_mark implementation, e.g., when delimcc is used *)
+let set_with_stack_mark : stackmark_region_fn -> unit =
+ fun smf -> with_stack_mark := smf
+
+
+(* ------------------------------------------------------------------------ *)
+(* Simple heap *)
+(* A mapping of keys to values. Priority is used for the sake of
+ efficient operations. Also, values with the same priority are
+ considered equivalent (belong to the same binding region)
+ and are collapsed, lazily.
+
+ The invariant: for each non-leaf
+ node, the priority of the node is strictly greater than the priorities
+ of any of the child nodes. The order of priorities between
+ the children can be arbitrary.
+*)
+type prio = int
+type 'v heap = Nil | HNode of prio * stackmark * 'v * 'v heap * 'v heap
+let empty = Nil
+
+let rec merge : 'v heap -> 'v heap -> 'v heap = fun h1 h2 ->
+ match (h1,h2) with
+ | (Nil,h) | (h,Nil)-> h
+ | (HNode (p1,k1,v1,l1,r1), HNode (p2,k2,v2,l2,r2)) ->
+ begin
+ match p1 - p2 with
+ | 0 -> HNode (p1,k1,v1, merge l1 l2, merge r1 r2) (* same keys *)
+ | n when n < 0 -> HNode (p2,k2,v2, merge h1 l2, r2)
+ | _ -> HNode (p1,k1,v1,l1,merge h2 r1)
+ end
+
+(* Remove the node with a given priority *)
+let rec remove : prio -> 'v heap -> 'v heap = fun p -> function
+ | Nil -> Nil
+ | HNode (pn,k,v,h1,h2) as h ->
+ begin
+ match p - pn with
+ | 0 -> merge h1 h2 (* p cannot occur in h1 or h2 *)
+ | n when n > 0 -> h (* entire tree has the lower prio *)
+ | _ -> HNode (pn,k,v, remove p h1, remove p h2)
+ end
+
+(* The representation of the possibly open code: AST plus the
+ set of free identifiers, annotated with the marks
+ of the corresponding with_binding_region forms
+*)
+type code_repr = Code of string loc heap * Parsetree.expression
+
+(* The closed code is AST *)
+type closed_code_repr = Parsetree.expression
+
+(* Check that the code is closed and return the closed code *)
+
+(* The same as close_code but return the closedness check as a thunk
+ rather than performing it.
+ This is useful for debugging and for showing the code
+*)
+let close_code_delay_check : code_repr -> closed_code_repr * (unit -> unit) =
+ function
+ | Code (Nil,ast) -> (ast,fun () -> ())
+ | Code (HNode (_,_,var,_,_),ast) ->
+ (ast, fun () ->
+ Format.fprintf Format.str_formatter
+ "The code built at %a is not closed: identifier %s bound at %a is free"
+ Location.print ast.pexp_loc var.txt Location.print var.loc;
+ failwith (Format.flush_str_formatter ()))
+
+let close_code_repr : code_repr -> closed_code_repr = fun cde ->
+ let (ast, check) = close_code_delay_check cde in
+ check (); ast
+
+let open_code : closed_code_repr -> code_repr = fun ast ->
+ Code (Nil,ast)
+
+(* Compiling a closed code value: a structural constant of
+ type code_repr
+ This constant is transported via CSP (although we could have
+ built a Typedtree node for that purpose.
+ *)
+let texp_code : ?node_id:string ->
+ Location.t -> Parsetree.expression_desc -> Typedtree.expression_desc =
+ fun ?(node_id="") loc desc ->
+ let ast = Ast_helper.Exp.mk ~loc desc in
+ (texp_csp (Obj.repr (open_code ast))).exp_desc
+
+
+(* ------------------------------------------------------------------------ *)
+(* Bindings in the future stage *)
+(* Recall, all bindings at the future stage are introduced by
+ patterns, and hence are simple names, without any module qualifications.
+*)
+let gensym_count = ref 0
+
+(* Generate a fresh name with a given base name *)
+let gensym : string -> string = fun s ->
+ incr gensym_count;
+ s ^ "_" ^ string_of_int !gensym_count
+
+let reset_gensym_counter () = gensym_count := 0
+
+(* Make a simple identifier unique *)
+let genident : string loc -> string loc = fun name ->
+ {name with txt = gensym name.txt}
+
+(* This is a run-time error, rather than a translation-time error *)
+let scope_extrusion_error :
+ detected:Location.t -> occurred:Location.t -> string loc -> 'a =
+ fun ~detected ~occurred var ->
+ Format.fprintf Format.str_formatter
+ "Scope extrusion detected at %a for code built at %a for the identifier %s bound at %a"
+ Location.print detected Location.print occurred
+ var.txt Location.print var.loc;
+ failwith (Format.flush_str_formatter ())
+
+(* Check to make sure that free variables in the potentially open
+ code fragment are valid.
+ If it weren't for delimited control, the order of stack marks is
+ stable; therefore, if the maximal mark is valid then all
+ smaller marks are valid as well.
+ Delimited control spoils all that.
+ When we capture some of the inner-bindings
+ in a continuation and then reinstall that continuation at the
+ top level, the `latest' free variable is valid but earlier are
+ no longer valid:
+
+ let r = ref ... in
+ .<fun x1 x2 -> .~(reset .<fun y1 y2 ->
+ .~(shift k (r := k; k .<0>.))>.)>.
+ .r .<2>.
+ Here, y1 and y2 are valid but x1 and x2 are not.
+*)
+let validate_vars : Location.t -> code_repr -> code_repr =
+ fun l -> function
+ | Code (Nil,_) as cde -> cde
+ | Code (h, ast) as cde -> begin
+ let rec check = function
+ | Nil -> ()
+ | HNode (_,sm,var,h1,h2) ->
+ if sm () then (check h1; check h2)
+ else scope_extrusion_error ~detected:l ~occurred:ast.pexp_loc var
+ in check h; cde
+ end
+
+let validate_vars_option : Location.t -> code_repr option ->
+ Parsetree.expression option * string loc heap =
+ fun l -> function
+ | None -> (None,Nil)
+ | Some e -> let Code (vars, e) = validate_vars l e in (Some e, vars)
+
+let validate_vars_map : Location.t ->
+ (Location.t -> 'a -> 'b * string loc heap) -> 'a list ->
+ 'b list * string loc heap = fun loc f xs ->
+ map_accum (fun acc x ->
+ let (y,vars) = f loc x in
+ (y, merge vars acc))
+ Nil xs
+
+let validate_vars_list : Location.t -> code_repr list ->
+ Parsetree.expression list * string loc heap = fun l cs ->
+ validate_vars_map l
+ (fun l c -> let Code (vars,e) = validate_vars l c in (e,vars)) cs
+
+(* Generate a fresh name off the given name, enter a new binding region
+ and evaluate a function passing it the generated name as code_repr.
+ Remove the generated name from the annotation on the resulting code_expr.
+ Return that result and the generated name.
+ This function embodies the translation of simple functions, for-loops,
+ simple let-expressions, etc.
+*)
+ (* Counter for assigning priorities to vars heap nodes. *)
+ (* Keep in mind the invariant that variables of the same priority
+ comes from the same binding location. So, we must keep the
+ priorities unique to binders. Giving binders monotonically
+ increasing priorities is helpful: the innermost binding
+ has the highest priority and it will be at the top of the heap,
+ the easiest to remove.
+ *)
+let prio_counter = ref 0
+
+let with_binding_region :
+ Location.t -> string loc -> (code_repr -> code_repr) ->
+ string loc * string loc heap * Parsetree.expression = fun l name f ->
+ let new_name = genident name in
+ let (vars,e) =
+ !with_stack_mark.stackmark_region_fn (fun mark ->
+ incr prio_counter;
+ let prio = !prio_counter in
+ let var_code = (* code that corresponds to the bound variable *)
+ Code (HNode (prio,mark,new_name,Nil,Nil),
+ Ast_helper.Exp.mk ~loc:name.loc (* the loc of the binder *)
+ (Pexp_ident (mkloc (Longident.Lident new_name.txt) new_name.loc))) in
+ let Code (vars,e) = validate_vars l (f var_code) in
+ (remove prio vars, e)) in
+ (new_name, vars, e)
+
+(* The most general version with several bindings and several expressions
+ that use the bindings
+ *)
+let with_binding_region_gen :
+ Location.t -> string loc list ->
+ (Location.t -> 'a -> 'b * string loc heap) -> (code_repr array -> 'a array) ->
+ string loc list * string loc heap * 'b list
+ = fun l names tr f ->
+ let new_names = List.map genident names in
+ let (vars,es) =
+ !with_stack_mark.stackmark_region_fn (fun mark ->
+ incr prio_counter;
+ let prio = !prio_counter in
+ let vars_code = Array.of_list (List.map (fun new_name ->
+ (* code that corresponds to a bound variable *)
+ Code (HNode (prio,mark,new_name,Nil,Nil),
+ Ast_helper.Exp.mk ~loc:new_name.loc (* the loc of the binder *)
+ (Pexp_ident (mkloc (Longident.Lident new_name.txt) new_name.loc))))
+ new_names) in
+ let cs = Array.to_list (f vars_code) in
+ let (es,vars) = map_accum (fun vars c ->
+ let (e,var) = tr l c in
+ (e,merge var vars)) Nil cs in
+ (remove prio vars, es)) in
+ (new_names, vars, es)
+
+(* ------------------------------------------------------------------------ *)
+(* Building Parsetree nodes *)
+
+(* Handle timestamp for builders of the type
+ Parsetree.expression -> Parsetree.expression
+*)
+let code_wrapper :
+ (Location.t -> Parsetree.expression -> Parsetree.expression) ->
+ (Location.t -> code_repr -> code_repr) =
+fun f l e ->
+ let Code (vars,e) = validate_vars l e in
+ Code (vars, f l e)
+
+(* building a typical Parsetree node: Pexp_assert of expression*)
+let build_assert : Location.t -> code_repr -> code_repr =
+ code_wrapper
+ (fun loc e -> Ast_helper.Exp.assert_ ~loc e)
+
+(* When we translate the typed-tree, we have to manually compile
+ the above code
+First, to see the AST for the phrase, invoke the top-level with the flag
+-dparsetree. Then
+ {pexp_loc = l; pexp_desc = Pexp_assert e}
+
+gives the parsetree:
+let build_assert_ast : Location.t -> Parsetree.expression -> Parsetree.expression =
+{pexp_loc = l1;
+ pexp_desc =
+ Pexp_record
+ ([(Location.mknoloc (Longident.parse "Parsetree.pexp_loc"),
+ Pexp_ident "l");
+ (Location.mknoloc (Longident.parse "Parsetree.pexp_desc"),
+ {pexp_loc = Location.none;
+ pexp_desc = Pexp_construct
+ ((Location.mknoloc (Longident.parse
+ "Parsetree.Pexp_assert")),
+ Some {pexp_loc = Location.none;
+ pexp_desc = Pexp_ident "e"},
+ false)})
+ ],
+ None)}
+type_expression
+
+If building the parsetree on our own, beware! For example, labels in
+Texp_record must be sorted, in their declared order!
+*)
+
+
+(* Other similar builders *)
+let build_lazy : Location.t -> code_repr -> code_repr =
+ code_wrapper @@
+ fun loc e -> Ast_helper.Exp.lazy_ ~loc e
+let build_bracket : Location.t -> code_repr -> code_repr =
+ code_wrapper @@
+ fun _ e -> {e with pexp_attributes =
+ attr_bracket :: e.pexp_attributes }
+let build_escape : Location.t -> code_repr -> code_repr =
+ code_wrapper @@
+ fun _ e -> {e with pexp_attributes =
+ attr_escape :: e.pexp_attributes}
+
+let build_sequence : Location.t -> code_repr -> code_repr -> code_repr =
+ fun loc e1 e2 ->
+ let Code (vars1,e1) = validate_vars loc e1 in
+ let Code (vars2,e2) = validate_vars loc e2 in
+ Code (merge vars1 vars2,
+ Ast_helper.Exp.sequence ~loc e1 e2)
+let build_while : Location.t -> code_repr -> code_repr -> code_repr =
+ fun loc e1 e2 ->
+ let Code (vars1,e1) = validate_vars loc e1 in
+ let Code (vars2,e2) = validate_vars loc e2 in
+ Code (merge vars1 vars2,
+ Ast_helper.Exp.while_ ~loc e1 e2)
+
+(* Build the application. The first element in the array is the
+ function. The others are arguments. *)
+let build_apply : Location.t -> (label * code_repr) array -> code_repr =
+ fun loc ea ->
+ assert (Array.length ea > 1);
+ match map_accum (fun vars (lbl,e) ->
+ let Code (var,e) = validate_vars loc e in
+ ((lbl,e),merge var vars))
+ Nil (Array.to_list ea) with
+ | (("",eh)::elt,vars) ->
+ Code (vars,
+ Ast_helper.Exp.apply ~loc eh elt)
+ | _ -> assert false
+
+
+let build_tuple : Location.t -> code_repr array -> code_repr =
+ fun loc ea ->
+ let (els,vars) = validate_vars_list loc (Array.to_list ea) in
+ Code (vars,
+ Ast_helper.Exp.tuple ~loc els)
+
+let build_array : Location.t -> code_repr array -> code_repr =
+ fun loc ea ->
+ let (els,vars) = validate_vars_list loc (Array.to_list ea) in
+ Code (vars,
+ Ast_helper.Exp.array ~loc els)
+
+let build_ifthenelse :
+ Location.t -> code_repr -> code_repr -> code_repr option -> code_repr =
+ fun loc e1 e2 eo ->
+ let Code (vars1,e1) = validate_vars loc e1 in
+ let Code (vars2,e2) = validate_vars loc e2 in
+ let (eo,varso) = validate_vars_option loc eo in
+ Code (merge vars1 (merge vars2 varso),
+ Ast_helper.Exp.ifthenelse ~loc e1 e2 eo)
+
+let build_construct :
+ Location.t -> Longident.t loc -> code_repr array -> code_repr =
+ fun loc lid args ->
+ let (args,vars) = validate_vars_list loc (Array.to_list args) in
+ Code (vars,
+ Ast_helper.Exp.construct ~loc lid
+ begin
+ match args with
+ | [] -> None
+ | [x] -> Some x
+ | xl -> Some (Ast_helper.Exp.tuple ~loc xl)
+ end)
+
+let build_record : Location.t -> (Longident.t loc * code_repr) array ->
+ code_repr option -> code_repr =
+ fun loc lel eo ->
+ let (lel,vars) = map_accum (fun vars (lbl,e) ->
+ let Code (var,e) = validate_vars loc e in
+ ((lbl,e),merge var vars))
+ Nil (Array.to_list lel) in
+ let (eo,varo) = validate_vars_option loc eo in
+ Code (merge vars varo,
+ Ast_helper.Exp.record ~loc lel eo)
+
+let build_field : Location.t -> code_repr -> Longident.t loc -> code_repr =
+ fun loc e lid ->
+ let Code (vars,e) = validate_vars loc e in
+ Code (vars,
+ Ast_helper.Exp.field ~loc e lid)
+
+let build_setfield :
+ Location.t -> code_repr -> Longident.t loc -> code_repr -> code_repr =
+ fun loc e1 lid e2 ->
+ let Code (vars1,e1) = validate_vars loc e1 in
+ let Code (vars2,e2) = validate_vars loc e2 in
+ Code (merge vars1 vars2,
+ Ast_helper.Exp.setfield ~loc e1 lid e2)
+
+let build_variant : Location.t -> string -> code_repr option -> code_repr =
+ fun loc l eo ->
+ let (eo,vars) = validate_vars_option loc eo in
+ Code (vars,
+ Ast_helper.Exp.variant ~loc l eo)
+
+let build_send : Location.t -> code_repr -> string -> code_repr =
+ fun loc e l ->
+ let Code (vars,e) = validate_vars loc e in
+ Code (vars,
+ Ast_helper.Exp.send ~loc e l)
+
+let build_open :
+ Location.t -> Longident.t loc -> override_flag -> code_repr -> code_repr =
+ fun loc l ovf e ->
+ let Code (vars,e) = validate_vars loc e in
+ Code (vars,
+ Ast_helper.Exp.open_ ~loc ovf l e)
+
+(* Build a function with a non-binding pattern, such as fun () -> ... *)
+let build_fun_nonbinding :
+ Location.t -> string -> Parsetree.pattern list ->
+ (code_repr option * code_repr) array -> code_repr =
+ fun loc label pats gbodies ->
+ let (egbodies,vars) =
+ validate_vars_map loc
+ (fun loc (eo,e) ->
+ let (eo,vo) = validate_vars_option loc eo in
+ let Code (vars,e) = validate_vars loc e in
+ ((eo,e),merge vo vars))
+ (Array.to_list gbodies) in
+ Code (vars,
+ match (egbodies,pats) with
+ | ([(None,e)],[p]) ->
+ Ast_helper.Exp.fun_ ~loc label None p e
+ | _ when label="" ->
+ Ast_helper.Exp.function_ ~loc
+ (List.map2 (fun p (eo,e) -> {pc_lhs=p;pc_guard=eo;pc_rhs=e})
+ pats egbodies)
+ | _ -> assert false)
+
+(* Build a Parsetree for a future-stage identifier
+ It is always in scope of with_binding_region:
+ Bound variables are always in scope of their binders;
+ A well-typed code has no unbound variables.
+let build_ident : Location.t -> string loc -> code_repr =
+ fun loc l ->
+ not_supported loc "vars not supported"
+ Code (add_timestamp (Some l)
+ {pexp_loc = loc;
+ pexp_desc = Pexp_ident (mkloc (Longident.Lident l.txt) l.loc)}
+*)
+
+(* Build a simple one-arg function, as described in the the title comments *)
+(* 'name' is the name of the variable from Ppat_var of the fun x -> ...
+ form. It is the real name with the location within the function pattern.
+ Use name.loc to identify the binder in the source code.
+*)
+let build_fun_simple :
+ Location.t -> string -> string loc -> (code_repr -> code_repr) -> code_repr =
+ fun loc label old_name fbody ->
+ let (name, vars, ebody) = with_binding_region loc old_name fbody in
+ let pat = Ast_helper.Pat.var ~loc:name.loc name in
+ Code (vars,
+ Ast_helper.Exp.fun_ ~loc label None pat ebody)
+
+let build_for :
+ Location.t -> string loc -> code_repr -> code_repr ->
+ bool -> (code_repr -> code_repr) -> code_repr =
+ fun loc old_name elo ehi dir fbody ->
+ let (name, varsb, ebody) = with_binding_region loc old_name fbody in
+ let Code (varsl,elo) = validate_vars loc elo in
+ let Code (varsh,ehi) = validate_vars loc ehi in
+ Code (merge varsb (merge varsl varsh),
+ Ast_helper.Exp.for_ ~loc
+ (Ast_helper.Pat.var ~loc:name.loc name) elo ehi
+ (if dir then Upto else Downto) ebody)
+
+
+let build_let_simple_nonrec :
+ Location.t -> string loc -> code_repr -> (code_repr -> code_repr) ->
+ code_repr = fun loc old_name e fbody ->
+ let (name, varsb, ebody) = with_binding_region loc old_name fbody in
+ let pat = Ast_helper.Pat.var ~loc:name.loc name in
+ let Code (varse,e) = validate_vars loc e in
+ Code (merge varsb varse,
+ Ast_helper.Exp.let_ ~loc Nonrecursive
+ [Ast_helper.Vb.mk ~loc pat e] ebody)
+
+(*
+let build_letrec :
+ Location.t -> string loc array ->
+ (code_repr array -> code_repr array) -> code_repr =
+ fun l old_names fbodies ->
+ let (names,vars,ebodies) =
+ with_binding_region_gen l (Array.to_list old_names) fbodies in
+ let (ebody,es) =
+ match ebodies with body::es -> (body,es) | _ -> assert false in
+ let pel = List.map2 (fun name e ->
+ ({ppat_loc = name.loc; ppat_desc = Ppat_var name},e)) names es in
+ Code (vars,
+ {pexp_loc = l;
+ pexp_desc = Pexp_let (Recursive, pel, ebody)})
+*)
+
+(*{{{ CSP *)
+
+(* ------------------------------------------------------------------------ *)
+(* Dealing with CSP *)
+
+exception CannotLift
+
+(* Analyze the type of the expression and figure out if we can lift it.
+ Raise CannotLift if cannot (e.g., the type is polymorphic), or it is too
+ much to bother.
+ TODO: lists, arrays, option types of liftable types are themselves
+ liftable. We can lift many more types. For arrays, check their length.
+ If the array is short, it should be lifted. For long arrays,
+ building a CSP is better (although it make take a bit longer since
+ we will have to invoke dyn_quote at run-time).
+
+ TODO: currently we generate calls to run-time functions like
+ lift_constant_int to do the Parsetree generation. In the future
+ we should `inline' those functions -- that is, obtain the Typedtree
+ for them and use the tree for building Texp_apply.
+*)
+let lift_as_literal :
+ Typedtree.expression -> Longident.t loc -> Typedtree.expression_desc =
+ fun exp li ->
+ let exp_ty =
+ Ctype.expand_head exp.exp_env (Ctype.correct_levels exp.exp_type) in
+ match Ctype.repr exp_ty with
+ | {desc = Tconstr(p, _, _)} when Path.same p Predef.path_int ->
+ texp_apply (texp_ident "Trx.lift_constant_int") [exp]
+ | {desc = Tconstr(p, _, _)} when Path.same p Predef.path_char ->
+ texp_apply (texp_ident "Trx.lift_constant_char") [exp]
+ | {desc = Tconstr(p, _, _)} when Path.same p Predef.path_bool ->
+ texp_apply (texp_ident "Trx.lift_constant_bool") [exp]
+ (* double and string are handled by dyn_quote *)
+ (* which hence handles polymorphic functions instantiated
+ to double and string.
+ *)
+ (* Deal with code type *)
+ | _ -> raise CannotLift
+
+(* TODO: similarly handle Const_nativeint, Const_int32, Const_int64 *)
+let lift_constant_int : int -> code_repr = fun x ->
+ open_code @@ Ast_helper.Exp.constant (Const_int x)
+
+let lift_constant_char : char -> code_repr = fun x ->
+ open_code @@ Ast_helper.Exp.constant (Const_char x)
+
+let lift_constant_bool : bool -> code_repr = fun x ->
+ let b = if x then "true" else "false" in
+ open_code @@ Ast_helper.Exp.construct
+ (Location.mknoloc (Longident.Lident b)) None
+
+
+(* Lift the run-time value v into a Parsetree for the code that, when
+ run, will produce v.
+ We do not have the type information for v, but we can examine
+ its run-time representation, to decide if we lift it is a source
+ literal or as a CSP.
+ We attach the CSP attribute to an expression, for the sake of better
+ printing (also to simplify translation when CSP occurs within nested
+ brackets).
+
+ TODO: also check for double_array_tag
+ and create a (structured) constant for a double array
+*)
+let obj_magic_exp =
+ Ast_helper.Exp.ident (Location.mknoloc @@
+ (Longident.Ldot (Longident.Lident "Obj","magic")))
+
+(* Check to see if a value is easy to serialize *)
+let easy_to_serialize : Obj.t -> bool =
+ let depth_bound = 5 in
+ let rec loop n v =
+ Obj.is_int v ||
+ let tag = Obj.tag v in
+ tag = Obj.string_tag ||
+ tag = Obj.double_tag ||
+ tag = Obj.double_array_tag ||
+ if n <= 0 ||
+ tag = Obj.closure_tag ||
+ tag >= Obj.no_scan_tag
+ then false
+ else let rec inner i =
+ if i < 0 then true else
+ loop (n-1) (Obj.field v i) && inner (i-1)
+ in inner (Obj.size v - 1)
+ in loop depth_bound
+
+
+let dyn_quote : Obj.t -> Longident.t loc -> code_repr =
+ fun v li ->
+ let csp_attr = attr_csp li in
+ open_code @@
+ match Obj.is_int v with
+ | true -> (* Looks like an integer: coerce from it using Obj.magic *)
+ Ast_helper.Exp.apply ~attrs:[csp_attr] ~loc:li.loc
+ obj_magic_exp [("",Ast_helper.Exp.constant (Const_int (Obj.obj v)))]
+ | false when Obj.tag v = Obj.double_tag ->
+ Ast_helper.Exp.constant (Const_float (string_of_float (Obj.obj v)))
+ | false when Obj.tag v = Obj.string_tag ->
+ Ast_helper.Exp.constant (Const_string (Obj.obj v,None))
+ | _ -> (* general case *)
+ let () =
+ if not @@ easy_to_serialize v then
+ debug_print ~loc:li.loc
+ "The CSP value is a closure or too deep to serialize" in
+ Ast_helper.Exp.apply ~attrs:[csp_attr] ~loc:li.loc
+ obj_magic_exp [("",Ast_helper.Exp.constant
+ (Const_string (Obj.obj v,None)))]
+
+
+(* Build the Typedtree that lifts the variable with the given path and type.
+ Since this code receives the type of the variable, we use the
+ type to generate the lifting code for that particular type.
+ For example, we build the code to convert a float
+ 0.1 to the Parsetree node Pexp_constant(Const_float "0.1")).
+ If we cannot or would not do the type-dependent lifting and we cannot
+ refer to the variable by name (e.g., because it is local),
+ we generate the call to the dynamic quoter, dyn_quote.
+ The latter will receive the actual value to quote and will generate,
+ at run-time, a Parsetree constant or CSP, based on that value.
+ *)
+let trx_csp :
+ Typedtree.expression -> Path.t -> Longident.t loc ->
+ Typedtree.expression_desc = fun exp p li ->
+ (* First we try lifting as a constant *)
+ try lift_as_literal exp li
+ with CannotLift ->
+ (* Then check if we can pass by reference *)
+ if ident_can_be_quoted p then
+ texp_code ~node_id:"*id*" exp.exp_loc
+ (Pexp_ident (Location.mkloc (path_to_lid p) li.loc))
+ else
+ (* Otherwise, do the lifting at run-time *)
+ texp_apply (texp_ident "Trx.dyn_quote") [exp; texp_lid li]
+
+(*{{{ Historical: hints on native mode CSP *)
+
+(* Native mode is moved out to the `userland'
+
+let remove_texp_cspval exp =
+ if !native_mode = false then exp else
+ failwith "native mode CSP are not impemented yet"
+
+old code
+ match exp.exp_desc with
+ | Texp_cspval (v,l) ->
+ let i = add_csp_value (v,l) in
+ let exp' = {exp with exp_desc = Texp_constant (Const_int i)} in
+ let desc = if !initial_native_compilation
+ then (Texp_apply (trx_array_get exp, [(Some !local_csp_arr_texp, Required);(Some exp', Required)]))
+ else (Texp_apply (trx_get_csp_value exp, [(Some exp', Required)])) in
+ {exp with exp_desc = desc}
+ | _ -> assert false
+*)
+
+(*}}}*)
+
+(*}}}*)
+
+
+(*{{{ Translating patterns and expressions using patterns *)
+
+
+(* Analyze and translate a pattern:
+ Typedtree.pattern -> Parsetree.pattern
+ The function is somewhat similar to tools/untypeast.ml:untype_pattern
+
+ However, we also determine and return the list of bound variables.
+ The list is in the reverse of the order of variables occurring in the pattern.
+ Finally, we check that labels and constructors may be quoted.
+
+ The algorithm of determining the names of bound variables is based
+ on Typedtree.pat_bound_idents. There is one subtle issue.
+ Normally all variables within a pattern are unique (patterns are
+ always linear). Identically named variables within a list of patterns, like
+ match ... with
+ | [x] ->
+ | [x;y] ->
+ are _distinct_ variables. They have different Ident.t values, even though
+ their names may be the same. However, components of an OR pattern
+ bind exactly the same identifiers. Don't count them twice!
+*)
+
+
+(* The first argument is a list of identifiers. Found identifiers are
+ prepended to that list. The order of identifiers is important!
+ If you change the traversal order, be sure to modify pattern_subst below!
+*)
+let rec trx_pattern :
+ (Ident.t * string loc) list -> Typedtree.pattern ->
+ Parsetree.pattern * (Ident.t * string loc) list = fun acc pat ->
+ let (pd,acc) = match pat with
+ | { pat_extra=[Tpat_unpack, _, _attrs]; pat_desc = Tpat_var (_,name); _ } ->
+ (Ppat_unpack name,acc) (* name must have been uppercase *)
+ | { pat_extra=[Tpat_type (_path, lid), _, _attrs]; _ } -> (Ppat_type lid,acc)
+ | { pat_extra= (Tpat_constraint ct, _, _attrs) :: rem; _ } ->
+ not_supported pat.pat_loc
+ "patterns with constraints, and other pat_extra";
+ (*
+ Ppat_constraint (untype_pattern { pat with pat_extra=rem },
+ untype_core_type ct)
+ *)
+ | _ -> match pat.pat_desc with
+ | Tpat_any -> (Ppat_any, acc)
+ | Tpat_var (id, name) when
+ (match (Ident.name id).[0] with 'A'..'Z' -> true | _ -> false) ->
+ (Ppat_unpack name,acc) (* We don't handle modules though...*)
+ | Tpat_var (id, name) ->
+ (Ppat_var name, (id,name)::acc)
+ | Tpat_alias (p, id, name) ->
+ let (p,acc) = trx_pattern acc p in
+ (Ppat_alias (p, name),(id,name)::acc)
+ | Tpat_constant cst -> (Ppat_constant cst, acc)
+ | Tpat_tuple lst ->
+ let (pl,acc) = map_accum trx_pattern acc lst
+ in (Ppat_tuple pl, acc)
+ | Tpat_construct (li, cdesc, args) ->
+ let lid = qualify_ctor li cdesc in
+ let (args,acc) = map_accum trx_pattern acc args in
+ (Ppat_construct (lid,
+ (match args with
+ | [] -> None
+ | [x] -> Some x
+ | _ -> Some (Ast_helper.Pat.tuple ~loc:pat.pat_loc args))),
+ acc)
+ | Tpat_variant (label, None, _) -> (Ppat_variant (label,None),acc)
+ | Tpat_variant (label, Some p, _) ->
+ let (p,acc) = trx_pattern acc p
+ in (Ppat_variant (label,Some p),acc)
+ | Tpat_record (lst, closed) ->
+ let dolab acc (li,ldesc,pat) =
+ let lid = qualify_label li ldesc in
+ let (pat,acc) = trx_pattern acc pat in
+ ((lid,pat),acc)
+ in
+ let (lpl,acc) = map_accum dolab acc lst in
+ (Ppat_record (lpl,closed),acc)
+ | Tpat_array lst ->
+ let (pl,acc) = map_accum trx_pattern acc lst
+ in (Ppat_array pl, acc)
+ | Tpat_or (p1, p2, _) ->
+ (* Invariant : both arguments bind the same variables *)
+ let (p1,acc) = trx_pattern acc p1 in
+ let (p2,_) = trx_pattern acc p2 in (* ignore vars in p2 *)
+ (Ppat_or (p1,p2),acc)
+ | Tpat_lazy p ->
+ let (p,acc) = trx_pattern acc p in (Ppat_lazy p,acc)
+ in
+ (Ast_helper.Pat.mk ~loc:pat.pat_loc ~attrs:pat.pat_attributes pd, acc)
+
+
+(* Process all patterns in the case list *)
+(* Patterns are processed left-to-right. The result is the processed
+ pattern list plus the list of names of the bound variables.
+ The variables are listed in the order they occur in the pattern.
+ Thus the following should hold:
+ let (pats,names,_) = trx_cl cl in
+ let (pats',acc) = pattern_subst_list names pats in
+ assert (pats = pats');
+ assert (acc = [])
+ The final result of trx_cl is the pattern binding the names.
+ We build an array pattern rather than a more appropriate tuple.
+ Using array forces a single type to all arguments. Although
+ it is phantom anyway, it is still a bummer. But with the tuple
+ we can't generically write build_fun.
+ The second argument, typ_expr, should normally be a code type.
+
+ This function is used when translating a future-stage function as the
+ present-stage whose argument is an array of variables.
+ See trx_bracket for functions, let, match and try
+*)
+let trx_cl : case list -> type_expr ->
+ Parsetree.pattern list * string loc list * Typedtree.pattern
+ = fun cl typ ->
+ let (pats, lst) =
+ map_accum (fun acc {c_lhs} -> trx_pattern acc c_lhs) [] cl in
+ let idnames = List.rev lst in
+ let (loc,env) =
+ match cl with {c_lhs=p}::_ -> (p.pat_loc, p.pat_env) |_ -> assert false in
+ (* Pattern representing one binding variable *)
+ let var_pat (id,name) =
+ {pat_loc = loc; pat_extra = []; pat_env = env;
+ pat_desc = Tpat_var (id,name);
+ pat_attributes=[];
+ pat_type = typ} in
+ (pats, List.map snd idnames,
+ {pat_loc = loc; pat_extra = []; pat_env = env;
+ pat_attributes=[];
+ pat_desc = Tpat_array (List.map var_pat idnames);
+ pat_type = Ctype.instance_def (Predef.type_array typ)})
+
+(* Substitute the names of bound variables in the pattern.
+ The new names are given in the string loc list. We
+ take advantage of the fact that patterns are linear and
+ the list of new names is ordered, in the order the bound
+ variables occur in the pattern. Therefore, we substitute based
+ on position.
+ OR-patterns bring complexity however: both branches of an OR
+ pattern bind exactly the same variables (but the order of
+ variable occurrence within branches may be different).
+ So for OR patterns we substitute by name, taking advantage
+ of the fact the new names differ from the old ones in _nnn
+ suffix. OR patterns are uncommon, so the complication of their processing
+ is not that bad.
+
+ This function is closely related to trx_pattern; It relies on the
+ same pattern traversal order as trx_pattern.
+ *)
+
+ (* two strings are the same up to (and including) n *)
+let rec same_upto s1 s2 n =
+ n < 0 || (s1.[n] = s2.[n] && same_upto s1 s2 (n-1))
+
+let rec pattern_subst : ?by_name:bool ->
+ string loc list -> Parsetree.pattern ->
+ Parsetree.pattern * string loc list = fun ?(by_name=false) acc pat ->
+ if acc = [] then (pat,acc) else (* no more variables to subst *)
+ let subst old_name acc =
+ if by_name then begin
+ let new_name =
+ try List.find (fun n ->
+ same_upto old_name.txt n.txt (String.rindex n.txt '_' - 1)) acc
+ with _ ->
+ begin
+ Format.fprintf Format.str_formatter "old_name %s %a\n"
+ old_name.txt Location.print old_name.loc;
+ List.iter (fun n -> Format.fprintf Format.str_formatter
+ "new name %s %a\n" n.txt Location.print n.loc) acc;
+ failwith (Format.flush_str_formatter ())
+ end
+ in
+ (new_name, acc) (* don't bother removing from acc*)
+ end
+ else match acc with
+ | h::t -> (h,t)
+ | _ -> assert false
+ in
+ let (desc,acc) = match pat.ppat_desc with
+ | Ppat_any as x -> (x,acc)
+ | Ppat_var old_name ->
+ let (new_name,acc) = subst old_name acc in (Ppat_var new_name,acc)
+ | Ppat_alias (p,old_name) ->
+ let (p,acc) = pattern_subst ~by_name acc p in
+ let (new_name,acc) = subst old_name acc in
+ (Ppat_alias (p,new_name),acc)
+ | Ppat_constant _ as x -> (x,acc)
+ | Ppat_tuple pl ->
+ let (pl,acc) = map_accum (pattern_subst ~by_name) acc pl in
+ (Ppat_tuple pl,acc)
+ | Ppat_construct (_,None) as x -> (x,acc)
+ | Ppat_construct (lid,Some p) ->
+ let (p,acc) = pattern_subst ~by_name acc p in
+ (Ppat_construct (lid,Some p),acc)
+ | Ppat_variant (_,None) as x -> (x,acc)
+ | Ppat_variant (l,Some p) ->
+ let (p,acc) = pattern_subst ~by_name acc p in
+ (Ppat_variant (l,Some p),acc)
+ | Ppat_record (pl,cf) ->
+ let (pl,acc) = map_accum (fun acc (l,p) ->
+ let (p,acc) = pattern_subst ~by_name acc p in ((l,p),acc)) acc pl in
+ (Ppat_record (pl,cf),acc)
+ | Ppat_array pl ->
+ let (pl,acc) = map_accum (pattern_subst ~by_name) acc pl in
+ (Ppat_array pl,acc)
+ | Ppat_or (p1,p2) ->
+ let (p1,acc') = pattern_subst ~by_name acc p1 in
+ let (p2,_) = pattern_subst ~by_name:true acc p2 in
+ (Ppat_or (p1,p2), acc')
+ | Ppat_constraint (p,cty) ->
+ let (p,acc) = pattern_subst ~by_name acc p in
+ (Ppat_constraint (p,cty), acc)
+ | Ppat_type _ as x -> (x,acc)
+ | Ppat_lazy p ->
+ let (p,acc) = pattern_subst ~by_name acc p in
+ (Ppat_lazy p, acc)
+ | Ppat_unpack _ as x -> (x,acc)
+ | _ -> assert false (* we do not create other forms of Ppat *)
+ in
+ ({pat with ppat_desc = desc}, acc)
+
+
+let pattern_subst_list :
+ string loc list -> Parsetree.pattern list ->
+ Parsetree.pattern list * string loc list = fun acc pl ->
+ map_accum (pattern_subst ~by_name:false) acc pl
+
+
+
+(* Build the general fun Parsetree *)
+
+(* Build the fresh variable name for cases and build the Parsetree
+ case list
+ We implicitly assume that all variables bound by patterns in any clause
+ scopes over all clauses. That seems like a wild assumption: for example,
+ in
+ function | x -> e1 | y -> e2
+ the variable x should scope only over e1 rather than also over e2.
+ However, this wild scoping is no problem: recall that we process
+ the Typedtree, and the type checker already determined the scoping.
+ In the type-checked example
+ let x = 1 in
+ function | x -> e1 | y -> x + 2
+ the variables are represented not just by their names but by their Path,
+ which contains the unique timestamp. Therefore, we are actually dealing with
+ let x/1 = 1 in
+ function | x/2 -> e1 | y/3 -> x/1 + 2
+ Therefore, if we make x/2 also scope over the second clause, that is
+ harmless.
+ Because of such scoping rules, prepare_cases is also useful
+ for processing letrec.
+*)
+let prepare_cases : Location.t ->
+ string loc heap -> (* extra free variables used in kontinuation *)
+ (* The following argument is a pair: a pattern list for the clauses
+ of the function, and the list of names of bound variables, in order.
+ *)
+ (Parsetree.pattern list * string loc list) ->
+ (* The following function returns the list of pairs of guards and bodies,
+ for each clause of the function
+ *)
+ (code_repr array -> (code_repr option * code_repr) array) ->
+ (* The continuation *)
+ (Parsetree.case list -> Parsetree.expression) -> code_repr =
+ fun loc evars (pats,old_names) fgbodies k ->
+ let tr loc (eo,e) =
+ let (eo,vo) = validate_vars_option loc eo in
+ let Code (vars,e) = validate_vars loc e in
+ ((eo,e),merge vo vars) in
+ let (names,vars,egbodies) =
+ with_binding_region_gen loc old_names tr fgbodies in
+ let pats =
+ if names = [] then pats else
+ let (pats,acc) = pattern_subst_list names pats in
+ assert (acc = []); pats
+ in
+ Code(merge evars vars,
+ k @@ List.map2 (fun p (eo,e) -> {pc_lhs=p;pc_guard=eo;pc_rhs=e})
+ pats egbodies)
+
+let build_fun :
+ Location.t -> string ->
+ (Parsetree.pattern list * string loc list) ->
+ (code_repr array -> (code_repr option * code_repr) array) -> code_repr =
+ fun loc label pon fgbodies ->
+ prepare_cases loc Nil pon fgbodies @@ function
+ | [{pc_lhs=p; pc_guard=None; pc_rhs=e}] ->
+ Ast_helper.Exp.fun_ ~loc label None p e
+ | cases when label="" ->
+ Ast_helper.Exp.function_ ~loc cases
+ | _ -> assert false
+
+
+(* Build the general let-Parsetree (like the fun-Parsetree) *)
+let build_let :
+ Location.t -> bool ->
+ (Parsetree.pattern list * string loc list) ->
+ (code_repr array -> (code_repr option * code_repr) array) -> code_repr =
+ fun loc recf pon fgbodies ->
+ prepare_cases loc Nil pon fgbodies @@ function
+ | [] | [_] -> assert false
+ (* The first case is the pseudo-case for the let body *)
+ | {pc_guard=None; pc_rhs=ebody} :: cases ->
+ Ast_helper.Exp.let_ ~loc (if recf then Recursive else Nonrecursive)
+ (List.map (function
+ | {pc_lhs;pc_guard=None;pc_rhs} ->
+ Ast_helper.Vb.mk ~loc:pc_lhs.ppat_loc pc_lhs pc_rhs
+ | _ -> assert false)
+ cases)
+ ebody
+ | _ -> assert false
+
+(* build match and try: both are very similar and similar to build_fun *)
+let build_match :
+ Location.t -> (Parsetree.pattern list * string loc list) -> code_repr ->
+ int ->
+ (code_repr array -> (code_repr option * code_repr) array) -> code_repr =
+ fun loc pon ec nregular fgbodies ->
+ let Code (evars,exp) = validate_vars loc ec in
+ let split : int -> 'a list -> 'a list * 'a list = fun n lst ->
+ let rec loop n acc lst = match (n,lst) with
+ | (0,lst) -> (List.rev acc,lst)
+ | (n,h::t) -> loop (n-1) (h::acc) t
+ | _ -> assert false
+ in loop n [] lst
+ in
+ prepare_cases loc evars pon fgbodies @@ fun cases ->
+ Ast_helper.Exp.match_ ~loc exp
+ (let (rc,ec) = split nregular cases in
+ rc @ List.map
+ (fun c ->
+ let pat = {c.pc_lhs with ppat_desc = Ppat_exception c.pc_lhs}
+ in {c with pc_lhs = pat}) ec)
+
+
+(* Essentially the same as build_match.
+ TODO: implement the same check on the timestamp of the expression to try
+*)
+let build_try :
+ Location.t -> (Parsetree.pattern list * string loc list) -> code_repr ->
+ (code_repr array -> (code_repr option * code_repr) array) -> code_repr =
+ fun loc pon ec fgbodies ->
+ let Code (evars,exp) = validate_vars loc ec in
+ prepare_cases loc evars pon fgbodies @@ fun cases ->
+ Ast_helper.Exp.try_ ~loc exp cases
+
+(*}}}*)
+
+
+(* ------------------------------------------------------------------------ *)
+(* The main function to translate away brackets. It receives
+ an expression at the level n > 0.
+
+ Since bracket-translation is somewhat similar to un-typechecking,
+ see tools/untypeast.ml for hints on mapping Typedtree.expression
+ to Parsetree.expression.
+
+TODO: an optimization idea. Consider <assert e> as a typical expression.
+We translate it to the invocation of build_assert that will construct
+the Parsetree node at run-time. However, if 'e' is simple (e.g., a constant)
+then we can construct the Parsetree node at compile time and pass it
+as a CSP. There are no longer any functions calls to make at run-time.
+So, we can modify the translation of <assert e> below to detect
+if the translation of e produced Texp_cspval. We extract the CSP value,
+invoke build_assert (at compile time, when trx.ml is run) to build
+the Pexp_assert node, and wrap it as a CSP.
+
+Essentially the result of trx_bracket should be like
+ Transl_bracket of Parsetree.expression option * Typedtree.expression
+The first part of the result is the code built-in at compile time.
+This part is None of the expression to translate contains an escape
+or a true CSP (global id is OK). Sometimes we need both parts: consider
+ <fun x -> x + ~(...)>
+When we translate x we don't know if we can take a shortcut and
+build the function code at translation time. So, we have to account
+for both possibilities. If we can build the function at compile time,
+we don't even need to rename the bound variable!
+
+*)
+
+(* Given a type [ty], return [ty code code ... code] (n times code).
+ When we push the bracket in, expressions that had type ty before
+ will have the type ty code.
+ Here, ty code is an abstract type whose concrete representation
+ is code_repr.
+ Generally speaking we don't have to adjust the types since the
+ type checking is finished. However, code generator may look
+ at types; it's better if we don't lie. Thus, as trx_bracket
+ translates the expression, it should also adjust the types.
+*)
+
+let rec wrap_ty_in_code : int -> type_expr -> type_expr = fun n ty ->
+ if n=0 then ty else
+ (* let clsfier = Btype.newgenvar () in *)
+ wrap_ty_in_code (n-1) (Predef.type_code ty)
+
+let map_option : ('a -> 'b) -> 'a option -> 'b option = fun f -> function
+ | None -> None
+ | Some x -> Some (f x)
+
+
+let rec trx_bracket : int -> expression -> expression = fun n exp ->
+ (*
+ let _ = debug_print "Texp_bracket" in
+ let rec prattr = function
+ | [] -> ()
+ | ({txt=name},_) :: t ->
+ debug_print ("attr: " ^ name); prattr t
+ in prattr exp.exp_attributes;
+ let _ = Location.print Format.err_formatter (exp.exp_loc) in
+ *)
+ (* Handle staging constructs, which are distinguished solely by
+ attributes *)
+ match what_stage_attr exp.exp_attributes with
+ | Stage0 -> trx_bracket_ n exp
+ (* see texp_braesc for the representation of brackets and escapes
+ in the Typedtree *)
+ | Bracket(_,attrs) ->
+ begin
+ match exp.exp_desc with
+ | Texp_sequence (_,exp) ->
+ {exp with exp_type = wrap_ty_in_code n exp.exp_type;
+ exp_attributes = attrs;
+ exp_desc =
+ texp_apply (texp_ident "Trx.build_bracket")
+ [texp_loc exp.exp_loc; trx_bracket (n+1) exp]}
+ | _ -> assert false (* corrupted representation of bracket *)
+ end
+ | Escape(_,attrs) ->
+ begin
+ match exp.exp_desc with
+ | Texp_sequence (_,exp) ->
+ if n = 1 then exp (* switch to 0 level *)
+ else
+ {exp with
+ exp_type = wrap_ty_in_code n exp.exp_type;
+ exp_attributes = attrs;
+ exp_desc = texp_apply (texp_ident "Trx.build_escape")
+ [texp_loc exp.exp_loc; trx_bracket (n-1) exp]}
+ | _ -> assert false (* corrupted representation of escape *)
+ end
+ | CSP(_,li,attrs) -> (* For CSP, we only need to propagate the CSP attr *)
+ {exp with
+ exp_type = wrap_ty_in_code n exp.exp_type;
+ exp_attributes = attrs;
+ exp_desc = texp_apply
+ (texp_ident "Trx.dyn_quote") [exp; texp_lid li]}
+
+ (* convert the case list to the function that receives the sequence
+ of bound variables and returns the array of translated guards and
+ bodies
+ *)
+and trx_case_list_body : int -> Typedtree.pattern ->
+ expression -> (* used as the template for the result: we use
+ the env, location info *)
+ case list -> expression = fun n binding_pat exp cl ->
+ (* Translate the future-stage function as the present-stage
+ function whose argument is an array of variables
+ (should be a tuple, really) and the type
+ some_targ code array -> tres code array
+ Using array forces a single type to all arguments. Although
+ it is phantom anyway, it is still a bummer. Instead of
+ array, we should have used a tuple. But then we can't
+ generically write build_fun.
+ *)
+ (* Pattern representing the function's argument:
+ array of variables bound by the original pattern, in order.
+ *)
+ let body =
+ texp_array (List.map (fun {c_guard;c_rhs;_} ->
+ texp_tuple [texp_option @@ map_option (trx_bracket n) c_guard;
+ trx_bracket n c_rhs])
+ cl) in
+ { exp with
+ exp_desc = Texp_function ("",[texp_case binding_pat body],Total);
+ exp_type = {exp.exp_type with desc =
+ Tarrow ("",binding_pat.pat_type, body.exp_type, Cok)}
+ }
+
+
+and trx_bracket_ : int -> expression -> expression = fun n exp ->
+ let new_desc = match exp.exp_desc with
+ (* Don't just do only for vd.val_kind = Val_reg
+ because (+) or Array.get are Val_prim *)
+ | Texp_ident (p,li,vd) ->
+ let stage = get_level vd.val_attributes in
+ (* We make CSP only if the variable is bound at the stage 0.
+ Variables bound at stage > 0 are subject to renaming.
+ They are translated into stage 0 variable but of a different
+ type (t code), as explained in the title comments.
+ *)
+ if stage = 0 then trx_csp exp p li
+ else
+ (* Future-stage bound variable becomes the present-stage
+ bound-variable, but at a different type.
+ *)
+ let () = assert (vd.val_kind = Val_reg) in
+ (* The drawback is that exp.exp_loc disappears. If the scope extrusion
+ is reported for a simple expression like <x>, we can no longer
+ print in the error message the location that <x> appeared.
+ We can only print the location x was bound.
+ *)
+ Texp_ident (p,li,{vd with val_type = wrap_ty_in_code n vd.val_type})
+
+ | Texp_constant cst ->
+ texp_code ~node_id:"*cst*" exp.exp_loc (Pexp_constant cst)
+
+ (* The most common case of let-expressions: non-recursive
+ let x = e in body *)
+ | Texp_let (Nonrecursive,[{vb_pat = {pat_desc = Tpat_var (_,name)} as pat;
+ vb_expr = e}],ebody) ->
+ let pat = {pat with pat_type = wrap_ty_in_code n pat.pat_type} in
+ texp_apply (texp_ident "Trx.build_let_simple_nonrec")
+ [texp_loc exp.exp_loc;
+ texp_string_loc name;
+ trx_bracket n e;
+ { exp with
+ exp_desc =
+ Texp_function ("",[texp_case pat (trx_bracket n ebody)],Total);
+ exp_type =
+ {exp.exp_type with desc =
+ Tarrow ("",pat.pat_type, wrap_ty_in_code n ebody.exp_type, Cok)}
+ }
+ ]
+
+ (* General case of let. There are two subcases: parallel and recursive:
+ let x = e1 and y = e2 ... in body
+ let rec x = e1 and y = e2 ... in body
+
+ The difference between them is profound: in the first case,
+ x and y do not scope over e1 and e2, but in the recursive case,
+ they do.
+ And yet we translate the two cases uniformly. Recall that we are
+ processing the Typedtree: the type checker already determined
+ the scoping rules. The variables are represented with their paths,
+ which bear unique timestamps. See the comment in prepare_cases
+ above.
+ *)
+ (* Recursive let:
+ let rec f = e1 [and g = e2 ...] in body
+ According to transl_let in bytecomp/translcore.ml,
+ the patterns in recursive let are very restrictive: elther
+ let rec var = ...
+ or
+ let rec _ as var = ...
+ For instance, let rec (x1,x2) = ... is not allowed.
+ We do this test here. For simplicity, we are not going to support
+ let rec _ as var = ...
+ pattern.
+
+ There is another constraint: see check_recursive_lambda in
+ bytecomp/translcore.ml. We use a simpler version of the test:
+ we allow only letrec expressions of the form
+ let rec f = fun x -> ....
+ that is,
+ let rec f x y ... =
+ *)
+ | Texp_let (recf,vbl,ebody) ->
+ let check_letrec ({vb_pat=p;vb_expr=e} as vb) =
+ begin
+ match p.pat_desc with
+ | Tpat_var (_,_) -> ()
+ | _ ->
+ trx_error @@ Location.errorf ~loc:p.pat_loc
+ "Only variables are allowed as left-hand side of `let rec'"
+ end;
+ match e.exp_desc with
+ | Texp_function (_,_,_) -> ()
+ | _ ->
+ trx_error @@ Location.errorf ~loc:vb.vb_loc
+ "Recursive let binding must be to a function"
+ (* Location.print e.exp_loc *)
+ in if recf = Recursive then
+ List.iter check_letrec vbl;
+ (* Artificially convert vbl to case list, making the body
+ the first case with the Pat_any pattern.
+ Of course the scoping rules are different for vbl and case list.
+ Again, scoping has been already determined and resolved,
+ and our case list processing assumes very wild scoping that
+ accommodates let, letrec, functions, etc.
+ *)
+ let cl =
+ {c_lhs = (* pseudo-pattern for ebody *)
+ {pat_desc = Tpat_any; pat_loc=ebody.exp_loc;
+ pat_attributes=[]; pat_extra=[];
+ pat_type=ebody.exp_type;
+ pat_env=ebody.exp_env};
+ c_guard=None;
+ c_rhs=ebody} ::
+ List.map (fun {vb_pat;vb_expr} -> texp_case vb_pat vb_expr) vbl in
+ let (pl,names,binding_pat) =
+ trx_cl cl (wrap_ty_in_code n (Btype.newgenvar ())) in
+ texp_apply (texp_ident "Trx.build_let")
+ [texp_loc exp.exp_loc;
+ texp_bool (recf = Recursive);
+ texp_pats_names pl names;
+ trx_case_list_body n binding_pat exp cl
+ ]
+
+ (* The most common case of functions: fun x -> body *)
+ | Texp_function (l,[{c_guard=None;
+ c_lhs={pat_extra=[];
+ pat_desc = Tpat_var (_,name)} as pat;
+ c_rhs=ebody}],_) ->
+ let pat = {pat with pat_type = wrap_ty_in_code n pat.pat_type} in
+ texp_apply (texp_ident "Trx.build_fun_simple")
+ [texp_loc exp.exp_loc;
+ texp_string l;
+ texp_string_loc name;
+ (* Translate the future-stage function as present-stage function;
+ with the same variables, but with a different type,
+ targ code -> tres code
+ *)
+ { exp with
+ exp_desc =
+ Texp_function
+ ("",[texp_case pat (trx_bracket n ebody)],Total);
+ exp_type =
+ {exp.exp_type with desc =
+ Tarrow ("",pat.pat_type, wrap_ty_in_code n ebody.exp_type, Cok)}
+ }
+ ]
+
+ | Texp_function (l,cl,_) ->
+ begin
+ match trx_cl cl (wrap_ty_in_code n (Btype.newgenvar ())) with
+ | (pl, [], _) -> (* non-binding pattern *)
+ texp_apply (texp_ident "Trx.build_fun_nonbinding")
+ [texp_loc exp.exp_loc;
+ texp_string l;
+ begin
+ let pl_exp = texp_ident "Trx.sample_pat_list" in
+ {pl_exp with
+ exp_desc = (texp_csp (Obj.repr pl)).exp_desc}
+ end;
+ texp_array (List.map (fun {c_guard;c_rhs;_} ->
+ texp_tuple [texp_option @@
+ map_option (trx_bracket n) c_guard;
+ trx_bracket n c_rhs])
+ cl)
+ ]
+ | (pl, names, binding_pat) ->
+ texp_apply (texp_ident "Trx.build_fun")
+ [texp_loc exp.exp_loc;
+ texp_string l;
+ texp_pats_names pl names;
+ trx_case_list_body n binding_pat exp cl
+ ]
+ end
+
+ | Texp_apply (e, el) ->
+ (* first, we remove from el the information added by the type-checker *)
+ let lel = List.fold_right (function (* keep the order! *)
+ | (_,None,_) -> fun acc -> acc
+ | (l,Some e,_) -> fun acc -> (l,e)::acc) el [] in
+ let lel = ("",e) :: lel in (* Add the operator *)
+ texp_apply (texp_ident "Trx.build_apply")
+ [texp_loc exp.exp_loc;
+ texp_array (List.map (fun (l,e) ->
+ texp_tuple [texp_string l;trx_bracket n e]) lel)]
+
+ (* Pretty much like a function *)
+ (* rcl: regular cases; ecl: exceptional cases *)
+ | Texp_match (e,rcl,ecl,_) ->
+ let cl = rcl @ ecl in (* handle all cases uniformly *)
+ let (pl,names,binding_pat) =
+ trx_cl cl (wrap_ty_in_code n (Btype.newgenvar ())) in
+ texp_apply (texp_ident "Trx.build_match")
+ [texp_loc exp.exp_loc;
+ texp_pats_names pl names;
+ trx_bracket n e;
+ texp_int @@ List.length rcl;
+ trx_case_list_body n binding_pat exp cl
+ ]
+
+ | Texp_try (e,cl) -> (* same as Texp_match *)
+ let (pl,names,binding_pat) =
+ trx_cl cl (wrap_ty_in_code n (Btype.newgenvar ())) in
+ texp_apply (texp_ident "Trx.build_try")
+ [texp_loc exp.exp_loc;
+ texp_pats_names pl names;
+ trx_bracket n e;
+ trx_case_list_body n binding_pat exp cl
+ ]
+
+ | Texp_tuple el ->
+ texp_apply (texp_ident "Trx.build_tuple")
+ [texp_loc exp.exp_loc;
+ texp_array (List.map (trx_bracket n) el)]
+
+ | Texp_construct (li, cdesc, args) ->
+ let lid = qualify_ctor li cdesc in
+ texp_apply (texp_ident "Trx.build_construct")
+ [texp_loc exp.exp_loc;
+ texp_lid lid;
+ texp_array (List.map (trx_bracket n) args)]
+
+ | Texp_variant (l,eo) -> (* polymorphic variant *)
+ texp_apply (texp_ident "Trx.build_variant")
+ [texp_loc exp.exp_loc;
+ texp_string l;
+ texp_option (map_option (trx_bracket n) eo)]
+
+ | Texp_record (lel,eo) ->
+ texp_apply (texp_ident "Trx.build_record")
+ [texp_loc exp.exp_loc;
+ texp_array (List.map (fun (li,ldesc,e) ->
+ texp_tuple [texp_lid (qualify_label li ldesc);
+ trx_bracket n e]) lel);
+ texp_option (map_option (trx_bracket n) eo)]
+
+ | Texp_field (e,li,ldesc) ->
+ texp_apply (texp_ident "Trx.build_field")
+ [texp_loc exp.exp_loc;
+ trx_bracket n e;
+ texp_lid (qualify_label li ldesc)]
+
+ | Texp_setfield (e1,li,ldesc,e2) ->
+ texp_apply (texp_ident "Trx.build_setfield")
+ [texp_loc exp.exp_loc;
+ trx_bracket n e1;
+ texp_lid (qualify_label li ldesc);
+ trx_bracket n e2]
+
+ | Texp_array el ->
+ texp_apply (texp_ident "Trx.build_array")
+ [texp_loc exp.exp_loc;
+ texp_array (List.map (trx_bracket n) el)]
+
+ | Texp_ifthenelse (e,et,efo) ->
+ texp_apply (texp_ident "Trx.build_ifthenelse")
+ [texp_loc exp.exp_loc;
+ trx_bracket n e;
+ trx_bracket n et;
+ texp_option (map_option (trx_bracket n) efo)]
+
+ | Texp_sequence (e1,e2) ->
+ texp_apply (texp_ident "Trx.build_sequence")
+ [texp_loc exp.exp_loc;
+ trx_bracket n e1; trx_bracket n e2]
+ | Texp_while (e1,e2) ->
+ texp_apply (texp_ident "Trx.build_while")
+ [texp_loc exp.exp_loc;
+ trx_bracket n e1; trx_bracket n e2]
+
+ | Texp_for (id, pat, elo, ehi, dir, ebody) ->
+ let name =
+ begin
+ match pat.ppat_desc with
+ | Ppat_any -> mknoloc "_for" (* the typechecker also makes a dummy*)
+ | Ppat_var x -> x
+ | _ -> assert false
+ end
+ in
+ texp_apply (texp_ident "Trx.build_for")
+ [texp_loc exp.exp_loc;
+ texp_string_loc name;
+ trx_bracket n elo;
+ trx_bracket n ehi;
+ texp_bool (dir = Upto);
+ let var_typ = wrap_ty_in_code n (Ctype.instance_def Predef.type_int) in
+ let pat = {pat_loc = exp.exp_loc; pat_extra = [];
+ pat_attributes = [];
+ pat_type = var_typ; pat_env = exp.exp_env;
+ pat_desc = Tpat_var (id,name)} in
+ { exp with
+ exp_desc =
+ Texp_function ("",[texp_case pat (trx_bracket n ebody)],Total);
+ exp_type =
+ {exp.exp_type with desc =
+ Tarrow ("",var_typ, wrap_ty_in_code n ebody.exp_type, Cok)}
+ }
+ ]
+
+ | Texp_send (e,m,_) ->
+ (* We don't check the persistence of the method: after all,
+ a method name is somewhat like a polymorphic variant.
+ It's perfectly OK to have a function fun x -> x # foo
+ *)
+ texp_apply (texp_ident "Trx.build_send")
+ [texp_loc exp.exp_loc;
+ trx_bracket n e;
+ texp_string (match m with
+ | Tmeth_name name -> name
+ | Tmeth_val id -> Ident.name id)]
+
+ | Texp_new (p,li,_) ->
+ check_path_quotable "Class" p;
+ texp_code ~node_id:"*new*" exp.exp_loc
+ (Pexp_new (Location.mkloc (path_to_lid p) li.loc))
+
+ | Texp_instvar (p1,p2,s) ->
+ not_supported exp.exp_loc "Objects (Texp_instvar)"
+ (* Alternatively: since instance variables are always bound
+ at level 0 (for now)
+ so this is like a csp variable
+ call_trx_mkcsp exp None (path_to_lid p2)
+ *)
+ | Texp_setinstvar _ -> not_supported exp.exp_loc "Objects (Texp_setinstvar)"
+ | Texp_override _ -> not_supported exp.exp_loc "Objects (Texp_override)"
+ | Texp_letmodule (id,s,me,e) -> not_supported exp.exp_loc "let module"
+
+ | Texp_assert e ->
+ texp_apply (texp_ident "Trx.build_assert")
+ [texp_loc exp.exp_loc; trx_bracket n e]
+
+ | Texp_lazy e ->
+ texp_apply (texp_ident "Trx.build_lazy")
+ [texp_loc exp.exp_loc; trx_bracket n e]
+
+ | Texp_object (cl,fl) -> not_supported exp.exp_loc "Objects"
+ | Texp_pack _ -> not_supported exp.exp_loc "First-class modules"
+ (* | _ -> not_supported exp.exp_loc "not yet supported" *)
+ in
+ (* See untype_extra in tools/untypeast.ml *)
+ let trx_extra (extra, loc, attr) exp = (* TODO: take care of attr *)
+ let desc =
+ match extra with
+ (* Should check that cty1 and cty2 contain only globally declared
+ type components
+ *)
+ | Texp_constraint cty ->
+ not_supported loc "Texp_constraint"
+ | Texp_coerce (cto,ct) ->
+ not_supported loc "Texp_coerce"
+ | Texp_open (ovf, path, lid, _) ->
+ (* I don't need local open since all the constructors
+ and identifiers are qualified anyway.
+ *)
+ exp.exp_desc
+ (*
+ check_path_quotable "Texp_open" path;
+ texp_apply (texp_ident "Trx.build_open")
+ [texp_loc exp.exp_loc;
+ texp_lid (mkloc (path_to_lid path) lid.loc);
+ texp_csp (Obj.repr ovf);
+ exp] (* exp is the result of trx_bracket *)
+ *)
+ | Texp_poly cto -> not_supported loc "Texp_poly"
+ | Texp_newtype s -> not_supported loc "Texp_newtype"
+ in {exp with exp_loc = loc; exp_desc = desc} (* type is the same: code *)
+ in
+ List.fold_right trx_extra exp.exp_extra
+ {exp with exp_type = wrap_ty_in_code n exp.exp_type;
+ exp_desc = new_desc}
+
+
+
+(*{{{ Typedtree traversal to eliminate bracket/escapes *)
+
+(* This part is obsolete *)
+
+(* ------------------------------------------------------------------------ *)
+(* Typedtree traversal to eliminate bracket/escapes *)
+
+(* Functions to help traverse and transform a tree.
+ We assume that every tree mapping function of the type 'a -> 'a
+ throws the exception Not_modified if the tree has not been
+ modified.
+ This protocol helps minimize garbage and prevent useless tree
+ duplication.
+
+ We do not traverse attributes.
+*)
+
+exception Not_modified
+
+let replace_list : ('a -> 'a) -> 'a list -> 'a list = fun f l ->
+ let rec loop mdf = function
+ | [] -> if mdf then [] else raise Not_modified
+ | h::t -> match (try Some (f h) with Not_modified -> None) with
+ | Some h -> h :: loop true t
+ | None -> h :: loop mdf t
+ in loop false l
+
+let replace_pair : ('a -> 'a) -> ('b -> 'b) -> 'a * 'b -> 'a * 'b =
+ fun f g (x,y) ->
+ match ((try Some (f x) with Not_modified -> None),
+ (try Some (g y) with Not_modified -> None)) with
+ | (None,None) -> raise Not_modified
+ | (Some x, None) -> (x,y)
+ | (None, Some y) -> (x,y)
+ | (Some x, Some y) -> (x,y)
+
+let replace_opt : ('a -> 'a) -> 'a option -> 'a option = fun f -> function
+ | Some e -> Some (f e)
+ | None -> raise Not_modified
+
+(* The main function to scan the typed tree at the 0 level and
+ detect brackets
+*)
+
+let rec trx_struct str =
+ {str with str_items =
+ replace_list (fun si -> {si with str_desc = trx_struct_item si.str_desc})
+ str.str_items}
+
+and trx_vb_list l =
+ replace_list (fun vb -> {vb with vb_expr = trx_exp vb.vb_expr}) l
+
+and trx_struct_item = function
+| Tstr_eval (e,a) -> Tstr_eval (trx_exp e,a)
+| Tstr_value (rf,vbl) ->
+ Tstr_value(rf, trx_vb_list vbl)
+| Tstr_primitive _
+| Tstr_type _
+| Tstr_typext _
+| Tstr_exception _ -> raise Not_modified
+| Tstr_module mb -> Tstr_module (trx_mb mb)
+| Tstr_recmodule mbl -> Tstr_recmodule (replace_list trx_mb mbl)
+| Tstr_modtype _
+| Tstr_open _ -> raise Not_modified
+| Tstr_class l ->
+ Tstr_class (replace_list (fun (dcl,sl,vf) -> (trx_cdcl dcl,sl,vf)) l)
+| Tstr_class_type _ -> raise Not_modified
+| Tstr_include id ->
+ Tstr_include {id with incl_mod = trx_me id.incl_mod}
+| Tstr_attribute _ -> raise Not_modified
+
+and trx_mb mb =
+ {mb with mb_expr = trx_me mb.mb_expr}
+
+and trx_me me =
+ {me with mod_desc = trx_me_desc me.mod_desc}
+
+and trx_me_desc = function
+| Tmod_ident _ -> raise Not_modified
+| Tmod_structure str -> Tmod_structure (trx_struct str)
+| Tmod_functor (i,l,t,me) -> Tmod_functor (i,l,t, trx_me me)
+| Tmod_apply (me1,me2,mc) ->
+ let (me1,me2) = replace_pair trx_me trx_me (me1,me2) in
+ Tmod_apply (me1, me2, mc)
+| Tmod_constraint (me,mt,mtc,mc) -> Tmod_constraint (trx_me me, mt, mtc, mc)
+| Tmod_unpack (e,mt) -> Tmod_unpack (trx_exp e,mt)
+
+and trx_cdcl class_decl =
+ {class_decl with ci_expr = trx_ce class_decl.ci_expr}
+
+and trx_ce class_expr =
+ {class_expr with cl_desc = trx_ce_desc class_expr.cl_desc}
+
+and trx_cl_struct cs =
+ {cs with cstr_fields =
+ replace_list (fun cf -> {cf with cf_desc = trx_cf cf.cf_desc})
+ cs.cstr_fields}
+
+and trx_ce_desc = function
+| Tcl_ident (_,_,_) -> raise Not_modified
+| Tcl_structure cs -> Tcl_structure (trx_cl_struct cs)
+| Tcl_fun (l,p,el,ce,pa) ->
+ let (el,ce) =
+ replace_pair (replace_list (fun (i,l,e) -> (i,l,trx_exp e)))
+ trx_ce (el,ce) in
+ Tcl_fun (l,p,el,ce,pa)
+| Tcl_apply (ce,el) ->
+ let repel (l,eo,o) = (l,replace_opt trx_exp eo,o) in
+ let (ce,el) = replace_pair trx_ce (replace_list repel) (ce,el) in
+ Tcl_apply (ce,el)
+| Tcl_let (rf,vbl,el2,ce) ->
+ let repel2 = replace_list (fun (i,l,e) -> (i,l,trx_exp e)) in
+ let ((vbl,el2),ce) = replace_pair (replace_pair trx_vb_list repel2) trx_ce
+ ((vbl,el2),ce)
+ in Tcl_let (rf,vbl,el2,ce)
+| Tcl_constraint (ce,ct,sl1,sl2,cty) ->
+ Tcl_constraint (trx_ce ce,ct,sl1,sl2,cty)
+
+and trx_cf = function
+| Tcf_inherit (ofl,ce,so,sl1,sl2) ->
+ Tcf_inherit (ofl,trx_ce ce,so,sl1,sl2)
+| Tcf_val (_,_,_,Tcfk_virtual _,_) -> raise Not_modified
+| Tcf_val (sl,mf,i,Tcfk_concrete (ovf,e),b) ->
+ Tcf_val (sl,mf,i,Tcfk_concrete (ovf,trx_exp e),b)
+| Tcf_method (sl,pf,Tcfk_virtual _) -> raise Not_modified
+| Tcf_method (sl,pf,Tcfk_concrete (ovf,e)) ->
+ Tcf_method (sl,pf,Tcfk_concrete (ovf,trx_exp e))
+| Tcf_constraint (_,_) -> raise Not_modified
+| Tcf_initializer e -> Tcf_initializer (trx_exp e)
+| Tcf_attribute _ -> raise Not_modified
+
+and trx_exp exp =
+ {exp with exp_desc = trx_expression exp.exp_desc}
+
+and trx_caselist l = replace_list (fun cas ->
+ let (g,rhs) = replace_pair (replace_opt trx_exp) trx_exp
+ (cas.c_guard,cas.c_rhs) in
+ {cas with c_guard = g; c_rhs = rhs})
+ l
+
+and trx_expression = function
+| Texp_ident (_,_,_)
+| Texp_constant _ -> raise Not_modified
+| Texp_let (rf, vbl, e) ->
+ let (vbl,e) = replace_pair trx_vb_list trx_exp (vbl,e)
+ in Texp_let (rf, vbl, e)
+| Texp_function (l,cl,p) ->
+ Texp_function (l,trx_caselist cl,p)
+| Texp_apply (e,el) ->
+ let repl (l,eo,op) = (l,replace_opt trx_exp eo,op) in
+ let (e,el) = replace_pair trx_exp (replace_list repl) (e,el)
+ in Texp_apply (e,el)
+| Texp_match (e,cl1,cl2,p) ->
+ let (e,(cl1,cl2)) = replace_pair
+ trx_exp (replace_pair trx_caselist trx_caselist) (e,(cl1,cl2))
+ in Texp_match (e,cl1,cl2,p)
+| Texp_try (e,cl) ->
+ let (e,cl) = replace_pair trx_exp trx_caselist (e,cl)
+ in Texp_try (e,cl)
+| Texp_tuple l -> Texp_tuple (replace_list trx_exp l)
+| Texp_construct (l,cd,el) ->
+ Texp_construct (l,cd,replace_list trx_exp el)
+| Texp_variant (l,eo) -> Texp_variant (l,replace_opt trx_exp eo)
+| Texp_record (ll,eo) ->
+ let repll (l,ld,e) = (l,ld,trx_exp e) in
+ let (ll,eo) = replace_pair (replace_list repll) (replace_opt trx_exp) (ll,eo)
+ in Texp_record (ll,eo)
+| Texp_field (e,l,ld) -> Texp_field (trx_exp e,l,ld)
+| Texp_setfield (e1,l,ld,e2) ->
+ let (e1,e2) = replace_pair trx_exp trx_exp (e1,e2)
+ in Texp_setfield (e1,l,ld,e2)
+| Texp_array el -> Texp_array (replace_list trx_exp el)
+| Texp_ifthenelse (e1,e2,eo) ->
+ let ((e1,e2),eo) = replace_pair (replace_pair trx_exp trx_exp)
+ (replace_opt trx_exp) ((e1,e2),eo)
+ in Texp_ifthenelse (e1,e2,eo)
+| Texp_sequence (e1,e2) ->
+ let (e1,e2) = replace_pair trx_exp trx_exp (e1,e2)
+ in Texp_sequence (e1,e2)
+| Texp_while (e1,e2) ->
+ let (e1,e2) = replace_pair trx_exp trx_exp (e1,e2)
+ in Texp_while (e1,e2)
+| Texp_for (i,p,e1,e2,df,e3) ->
+ let ((e1,e2),e3) = replace_pair (replace_pair trx_exp trx_exp)
+ trx_exp ((e1,e2),e3)
+ in Texp_for (i,p,e1,e2,df,e3)
+| Texp_send (e1,m,eo) ->
+ let (e1,eo) = replace_pair trx_exp (replace_opt trx_exp) (e1,eo)
+ in Texp_send (e1,m,eo)
+| Texp_new (_,_,_)
+| Texp_instvar (_,_,_) -> raise Not_modified
+| Texp_setinstvar (p1,p2,l,e) -> Texp_setinstvar (p1,p2,l,trx_exp e)
+| Texp_override (p, el) ->
+ Texp_override (p, replace_list (fun (p,l,e) -> (p,l,trx_exp e)) el)
+| Texp_letmodule (i,l,me,e) ->
+ let (me,e) = replace_pair trx_me trx_exp (me,e)
+ in Texp_letmodule (i,l,me,e)
+| Texp_assert e -> Texp_assert (trx_exp e)
+| Texp_lazy e -> Texp_lazy (trx_exp e)
+| Texp_object (cs,sl) -> Texp_object (trx_cl_struct cs,sl)
+| Texp_pack me -> Texp_pack (trx_me me)
+(*
+| Texp_bracket e ->
+ let trx_exp e = try trx_exp e with Not_modified -> e in
+ (trx_bracket trx_exp 1 e).exp_desc
+
+| Texp_escape _ -> assert false (* Not possible in well-typed code *)
+| Texp_cspval (_,_) -> raise Not_modified
+*)
+
+
+(* public interface *)
+let trx_structure str =
+ try trx_struct str with Not_modified -> str
+
+(*}}}*)
+
+
diff -Naur ocaml-4.02.1/typing/trx.mli ocaml-ber-n102/typing/trx.mli
--- ocaml-4.02.1/typing/trx.mli 1970-01-01 01:00:00.000000000 +0100
+++ ocaml-ber-n102/typing/trx.mli 2015-01-10 16:27:06.932031073 +0000
@@ -0,0 +1,171 @@
+(* BER MetaOCaml compilation
+ Transforming the Typedtree to eliminate brackets and escapes,
+ replacing them with calls to ordinary OCaml functions
+ to build the code representation (that is, Parsetree).
+*)
+
+val meta_version : string
+(** [meta_version] is the version of BER MetaOCaml*)
+
+(* The function to process the body of the bracket at level n.
+ This function `lifts' the Typedtree to the code that will evaluate
+ to the corresponding Parsetree.
+*)
+val trx_bracket : int -> Typedtree.expression -> Typedtree.expression
+
+(* The following functions deal with the representation of brackets,
+ escapes and CPS in Parsetree and Typedtree.
+ Staging annotations and other levels are distinguished by
+ attributes.
+ The following functions are used by the typecore.ml as well
+ when building the Typedtree.
+*)
+
+(* The result of what_stage_attr *)
+type stage_attr_elim =
+ | Stage0
+ | Bracket of Parsetree.attribute * (* bracket attribute *)
+ Parsetree.attributes (* other attributes *)
+ | Escape of Parsetree.attribute * (* escape attribute *)
+ Parsetree.attributes (* other attributes *)
+ | CSP of Parsetree.attribute *
+ Longident.t Location.loc * (* CSP attribute and lid *)
+ Parsetree.attributes (* other attributes *)
+
+(* Determining if an AST node bears a staging attribute *)
+val what_stage_attr : Parsetree.attributes -> stage_attr_elim
+
+(* Build a Typedtree node for brackets or escape (the attribute tells
+ which is which)
+*)
+val texp_braesc :
+ Parsetree.attribute -> Typedtree.expression -> Env.t -> Types.type_expr ->
+ Typedtree.expression
+
+(* Build a Typedtree node for a CSP *)
+val texp_csp_raw :
+ Parsetree.attribute -> Asttypes.constant -> Env.t -> Types.type_expr ->
+ Typedtree.expression
+
+(* Staging level
+ It is set via an attribute on the value_description in the Typedtree
+*)
+type stage = int (* staging level *)
+val attr_level : stage -> Parsetree.attribute
+val get_level : Parsetree.attributes -> stage
+
+(* If the attribute is present, the expression is non-expansive
+ We use physical equality comparison, to speed things up
+*)
+val attr_nonexpansive : Parsetree.attribute
+
+(* The following functions operate on untyped code_repr.
+ We cannot use the type constructor 'code' here since
+ it is not available in the bootstrap compiler.
+*)
+
+(* The representation of possibly code: abstract *)
+type code_repr
+
+type closed_code_repr = private Parsetree.expression
+
+(* Check that the code is closed and return the closed code *)
+val close_code_repr : code_repr -> closed_code_repr
+
+(* The same as close_code but return the closedness check as a thunk
+ rather than performing it.
+ This is useful for debugging and for showing the code:
+ If there is a scope extrusion error, it is still useful
+ to show the code with the extrusion before throwing the scope-extrusion
+ exception.
+*)
+val close_code_delay_check : code_repr -> closed_code_repr * (unit -> unit)
+
+(* Total: a closed code can always be used in slices, etc. *)
+val open_code : closed_code_repr -> code_repr
+
+(* Adjusting the implementation of stackmarks -- needed when delimited
+ control is used (other than mere exceptions).
+*)
+type stackmark = unit -> bool (* true if valid *)
+type stackmark_region_fn =
+ {stackmark_region_fn : 'w. (stackmark -> 'w) -> 'w}
+val set_with_stack_mark : stackmark_region_fn -> unit
+
+
+(* The following names are used by Trx itself to construct a Parsetree
+ or as templates to build the Typedtree.
+ Trx may generate code the refers to the functions below.
+ Therefore, do NOT rename the functions or change their types!
+*)
+
+val loc_none : Location.t
+val sample_lid : Longident.t Location.loc (* A template for lid expressions *)
+val sample_name : string Location.loc
+val sample_pat_list : Parsetree.pattern list
+val sample_pats_names : Parsetree.pattern list * string Location.loc list
+
+ (* Run-time quotator *)
+val dyn_quote : Obj.t -> Longident.t Location.loc -> code_repr
+
+val lift_constant_int : int -> code_repr
+val lift_constant_char : char -> code_repr
+val lift_constant_bool : bool -> code_repr
+
+(* Builders of the Parsetree *)
+val build_assert : Location.t -> code_repr -> code_repr
+val build_lazy : Location.t -> code_repr -> code_repr
+val build_bracket : Location.t -> code_repr -> code_repr
+val build_escape : Location.t -> code_repr -> code_repr
+
+val build_sequence : Location.t -> code_repr -> code_repr -> code_repr
+val build_while : Location.t -> code_repr -> code_repr -> code_repr
+
+val build_apply : Location.t -> (Asttypes.label * code_repr) array -> code_repr
+
+val build_tuple : Location.t -> code_repr array -> code_repr
+val build_array : Location.t -> code_repr array -> code_repr
+val build_ifthenelse :
+ Location.t -> code_repr -> code_repr -> code_repr option -> code_repr
+val build_construct :
+ Location.t -> Longident.t Location.loc -> code_repr array -> code_repr
+val build_record :
+ Location.t -> (Longident.t Location.loc * code_repr) array ->
+ code_repr option -> code_repr
+val build_field :
+ Location.t -> code_repr -> Longident.t Location.loc -> code_repr
+val build_setfield :
+ Location.t -> code_repr -> Longident.t Location.loc -> code_repr -> code_repr
+val build_variant : Location.t -> string -> code_repr option -> code_repr
+val build_send : Location.t -> code_repr -> string -> code_repr
+val build_open :
+ Location.t -> Longident.t Location.loc -> Asttypes.override_flag ->
+ code_repr -> code_repr
+val build_fun_nonbinding :
+ Location.t -> string -> Parsetree.pattern list ->
+ (code_repr option * code_repr) array -> code_repr
+val build_fun_simple :
+ Location.t -> string -> string Location.loc ->
+ (code_repr -> code_repr) -> code_repr
+val build_for :
+ Location.t -> string Location.loc -> code_repr -> code_repr ->
+ bool -> (code_repr -> code_repr) -> code_repr
+val build_let_simple_nonrec :
+ Location.t -> string Location.loc -> code_repr ->
+ (code_repr -> code_repr) -> code_repr
+val build_fun :
+ Location.t -> string ->
+ (Parsetree.pattern list * string Location.loc list) ->
+ (code_repr array -> (code_repr option * code_repr) array) -> code_repr
+val build_let :
+ Location.t -> bool ->
+ (Parsetree.pattern list * string Location.loc list) ->
+ (code_repr array -> (code_repr option * code_repr) array) -> code_repr
+val build_match :
+ Location.t -> (Parsetree.pattern list * string Location.loc list) ->
+ code_repr -> int ->
+ (code_repr array -> (code_repr option * code_repr) array) -> code_repr
+val build_try :
+ Location.t -> (Parsetree.pattern list * string Location.loc list) ->
+ code_repr ->
+ (code_repr array -> (code_repr option * code_repr) array) -> code_repr
diff -Naur ocaml-4.02.1/typing/typecore.ml ocaml-ber-n102/typing/typecore.ml
--- ocaml-4.02.1/typing/typecore.ml 2015-01-10 16:27:54.274865552 +0000
+++ ocaml-ber-n102/typing/typecore.ml 2015-01-10 16:27:06.932031073 +0000
@@ -93,6 +93,91 @@
Env.t -> Location.t -> Parsetree.class_structure ->
Typedtree.class_structure * Types.class_signature * string list)
+(* NNN: begin
+ The current stage level.
+ Type-checking the body of a bracket increases the level,
+ type-checking of an escape decreases.
+ Be sure to reset upon any exception;
+ alternatively; reset when beginning a new type-level
+ expression or binding
+ (whenever you do Typetexp.reset_type_variables();)
+
+ Check all instances of Env.add_value and make sure that
+ we record the stage of every identifier that is added to the
+ value env (unless the stage is 0).
+also check all val_attributes and Val_reg
+*)
+let global_stage : Trx.stage ref = ref 0
+
+(* Obsolete; kept for reference
+
+ The list of active classifiers. The length of the list
+ is the level of an expression.
+ Type-checking the body of a bracket adds a type variable
+ to the list; type-checking of an escape removes the
+ top-most classifier.
+ Be sure to reset this list upon any exception;
+ alternatively; reset the list when beginning a new type-level
+ expression or binding
+ (whenever you do Typetexp.reset_type_variables();)
+
+let global_stage : Env.stage ref = ref []
+
+ Unify classifier lists, *right-to-left*
+ See the bug Tue Jan 20 12:18:00 GMTST 2004 in XXCC-BUG-OPEN-FIXED
+ why we need this order.
+ The current classifier is left-most, and the lists don't have
+ to have the same length.
+ Example:
+ .<fun x -> .< x >. >.
+ When type-checking the innermost bracket, the global_stage
+ will contain ['b,'a] and the level of x will be ['a]
+ The unification will succeed, without changing anything, as expected.
+
+let unify_stage env tl1 tl2 =
+ let rec loop = function
+ | (t1::tl1,t2::tl2) -> unify env t1 t2; loop (tl1,tl2)
+ | _ -> ()
+ in loop (List.rev tl1, List.rev tl2)
+*)
+
+(* This function does not take the env argument. Normally env affects
+ the printing of paths (search for raise_wrong_stage_error
+ in this file and printtyp.ml).
+ The particular error message we emit here does not use paths.
+*)
+let raise_wrong_stage_error loc n m =
+ raise @@
+ Error_forward(Location.errorf ~loc
+ "Wrong level: variable bound at level %d and used at level %d" n m)
+
+let raise_unsupported loc txt =
+ raise @@
+ Error_forward(Location.errorf ~loc
+ "Not supported within brackets: %s" txt)
+
+let with_stage_up body =
+ let old_stage = !global_stage in
+ let () = incr global_stage in
+ try
+ let r = body () in
+ global_stage := old_stage; r
+ with e ->
+ global_stage := old_stage; raise e
+
+let with_stage_down loc env body =
+ let old_stage = !global_stage in
+ if !global_stage = 0 then
+ raise @@ Error_forward(Location.errorf ~loc
+ "Wrong level: escape at level 0");
+ decr global_stage;
+ try
+ let r = body () in
+ global_stage := old_stage; r
+ with e ->
+ global_stage := old_stage; raise e
+(* NNN end *)
+
(*
Saving and outputting type information.
We keep these function names short, because they have to be
@@ -1258,7 +1343,7 @@
let check = if as_var then check_as else check in
Env.add_value ?check id
{val_type = ty; val_kind = Val_reg; Types.val_loc = loc;
- val_attributes = [];
+ val_attributes = [Trx.attr_level !global_stage] (* NNN *)
} env
)
pv env,
@@ -1301,7 +1386,8 @@
((id', name, id, ty)::pv,
Env.add_value id' {val_type = ty;
val_kind = Val_ivar (Immutable, cl_num);
- val_attributes = [];
+ val_attributes =
+ [Trx.attr_level !global_stage]; (* NNN *)
Types.val_loc = loc;
} ~check
env))
@@ -1325,6 +1411,10 @@
let pv = !pattern_variables in
pattern_variables := [];
let (val_env, met_env, par_env) =
+ (* NNN we don't record stage for
+ Env.add_value below
+ since we don't handle classes within brackets.
+ *)
List.fold_right
(fun (id, ty, name, loc, as_var) (val_env, met_env, par_env) ->
(Env.add_value id {val_type = ty;
@@ -1377,6 +1467,7 @@
(* Generalization criterion for expressions *)
let rec is_nonexpansive exp =
+ List.memq Trx.attr_nonexpansive exp.exp_attributes || (* NNN *)
match exp.exp_desc with
Texp_ident(_,_,_) -> true
| Texp_constant _ -> true
@@ -1491,7 +1582,14 @@
approx_type env sty
| _ -> newvar ()
-let rec type_approx env sexp =
+let rec type_approx env sexp = (* NNN the whole function *)
+ let open Trx in
+ match what_stage_attr sexp.pexp_attributes with
+ | Stage0 -> type_approx_orig env sexp
+ (* instance env @@ Predef.type_code @@ type_approx_orig env sexp *)
+ | _ -> newvar ()
+and
+ type_approx_orig env sexp = (* NNN end *)
match sexp.pexp_desc with
Pexp_let (_, _, e) -> type_approx env e
| Pexp_fun (p, _, _, e) when is_optional p ->
@@ -1702,6 +1800,11 @@
I don't think this is what we want *)
let (path, desc) = Env.lookup_value (Longident.Lident s) env in
match path with
+ (* NNN The code below uses the existing desc (value-descriptor)
+ as the template and simply changes val_type.
+ The attributes, specifically staging level attribute,
+ are preserved then.
+ *)
Path.Pident id ->
let desc = {desc with val_type = correct_levels desc.val_type} in
Env.add_value id desc env
@@ -1736,8 +1839,66 @@
(Cmt_format.Partial_expression exp :: previous_saved_types);
exp
+(* NNN This whole function type_expect_ *)
+(* Type checking staging constructs *)
+(* If we are type-checking bracket at level 0, don't build the
+ bracket Texp node. Rather, invoke trx_bracket to translate
+ the bracket body and convert it to the c ode generator.
+*)
and type_expect_ ?in_function env sexp ty_expected =
let loc = sexp.pexp_loc in
+ let open Trx in
+ (* Keep in mind that there may be several metaocaml attributes,
+ and their order matters.
+ *)
+ match what_stage_attr sexp.pexp_attributes with
+ | Stage0 -> type_expect_orig ?in_function env sexp ty_expected
+ | Bracket(battr,attrs) ->
+ (* Typechecking bracket *)
+ (* follow Pexp_array or Pexp_lazy as a template *)
+ (* Expected type: ty code where ty is the type
+ of the expression within brackets.
+ *)
+ let ty = newgenvar() in (* expected type for the bracketed sexp *)
+ let to_unify = Predef.type_code ty in
+ unify_exp_types loc env to_unify ty_expected;
+ let exp =
+ with_stage_up (fun () ->
+ (* drop bracket attr *)
+ let sexp = {sexp with pexp_attributes = attrs} in
+ type_expect env sexp ty) in
+ re @@
+ if !global_stage = 0 then
+ (* Check if the expression non-expansive before the translation *)
+ let nonexp = is_nonexpansive exp in
+ let exp = trx_bracket 1 exp in
+ {exp with exp_type = instance env ty_expected;
+ exp_attributes =
+ if nonexp then attr_nonexpansive :: exp.exp_attributes
+ else exp.exp_attributes}
+ else
+ texp_braesc battr exp env (instance env ty_expected)
+
+ (* NNN: Typechecking escapes *)
+ (* If ~e is expected to have the type ty then
+ e is expected to have the type ty code
+ *)
+ | Escape(battr,attrs) ->
+ with_stage_down loc env (fun () ->
+ let sexp_ty_expected = Predef.type_code ty_expected in
+ let sexp = {sexp with pexp_attributes = attrs} in (* drop bracket attr *)
+ let exp = type_expect env sexp sexp_ty_expected in
+ re @@
+ texp_braesc battr exp env (instance env ty_expected))
+
+ (* There is nothing special in type-checking CSPs.
+ After lifting, a CSP value becomes an ordinaru expression.
+ *)
+ | _ -> type_expect_orig ?in_function env sexp ty_expected
+ (* NNN end *)
+
+and type_expect_orig ?in_function env sexp ty_expected = (* NNN *)
+ let loc = sexp.pexp_loc in
(* Record the expression type before unifying it with the expected type *)
let rue exp =
unify_exp env (re exp) (instance env ty_expected);
@@ -1756,6 +1917,7 @@
let name = Path.name ~paren:Oprint.parenthesized_ident path in
Stypes.record (Stypes.An_ident (loc, name, annot))
end;
+ let stage = Trx.get_level desc.val_attributes in (* NNN *)
rue {
exp_desc =
begin match desc.val_kind with
@@ -1779,9 +1941,13 @@
Env.add_required_global (Path.head p);
Texp_ident(path, lid, desc)*)
| _ ->
+ if stage > !global_stage then (* NNN *)
+ raise_wrong_stage_error loc stage !global_stage (* NNN *)
+ else (* NNN *)
Texp_ident(path, lid, desc)
end;
exp_loc = loc; exp_extra = [];
+(* NNN: Instantiates type scheme to a type *)
exp_type = instance env desc.val_type;
exp_attributes = sexp.pexp_attributes;
exp_env = env }
@@ -1875,9 +2041,9 @@
in
type_expect ?in_function env sfun ty_expected
(* TODO: keep attributes, call type_function directly *)
- | Pexp_fun (l, None, spat, sexp) ->
+ | Pexp_fun (l, None, spat, sexp_body) -> (* NNN fixing the bug: sexp_body *)
type_function ?in_function loc sexp.pexp_attributes env ty_expected
- l [{pc_lhs=spat; pc_guard=None; pc_rhs=sexp}]
+ l [{pc_lhs=spat; pc_guard=None; pc_rhs=sexp_body}]
| Pexp_function caselist ->
type_function ?in_function
loc sexp.pexp_attributes env ty_expected "" caselist
@@ -2195,7 +2361,8 @@
| Ppat_any -> Ident.create "_for", env
| Ppat_var {txt} ->
Env.enter_value txt {val_type = instance_def Predef.type_int;
- val_attributes = [];
+ val_attributes = (* NNN *)
+ [Trx.attr_level !global_stage];
val_kind = Val_reg; Types.val_loc = loc; } env
~check:(fun s -> Warnings.Unused_for_index s)
| _ ->
@@ -2357,7 +2524,8 @@
Texp_ident(Path.Pident method_id, lid,
{val_type = method_type;
val_kind = Val_reg;
- val_attributes = [];
+ val_attributes = (* NNN *)
+ [Trx.attr_level !global_stage];
Types.val_loc = Location.none});
exp_loc = loc; exp_extra = [];
exp_type = method_type;
@@ -2428,6 +2596,8 @@
exp_env = env }
end
| Pexp_setinstvar (lab, snewval) ->
+ if !global_stage != 0 then (* NNN *)
+ raise_unsupported loc "setinstvar"; (* NNN *)
begin try
let (path, desc) = Env.lookup_value (Longident.Lident lab.txt) env in
match desc.val_kind with
@@ -2452,6 +2622,8 @@
raise(Error(loc, env, Unbound_instance_variable lab.txt))
end
| Pexp_override lst ->
+ if !global_stage != 0 then (* NNN *)
+ raise_unsupported loc "override"; (* NNN *)
let _ =
List.fold_right
(fun (lab, _) l ->
@@ -2490,6 +2662,8 @@
assert false
end
| Pexp_letmodule(name, smodl, sbody) ->
+ if !global_stage != 0 then (* NNN *)
+ raise_unsupported loc "letmodule"; (* NNN *)
let ty = newvar() in
(* remember original level *)
begin_def ();
@@ -3094,7 +3268,7 @@
exp_desc =
Texp_ident(Path.Pident id, mknoloc (Longident.Lident name),
{val_type = ty; val_kind = Val_reg;
- val_attributes = [];
+ val_attributes = [Trx.attr_level !global_stage]; (* NNN *)
Types.val_loc = Location.none})}
in
let eta_pat, eta_var = var_pair "eta" ty_arg in
@@ -3722,6 +3896,7 @@
let type_binding env rec_flag spat_sexp_list scope =
Typetexp.reset_type_variables();
+ global_stage := 0; (* NNN *)
let (pat_exp_list, new_env, unpacks) =
type_let
~check:(fun s -> Warnings.Unused_value_declaration s)
@@ -3739,17 +3914,34 @@
let type_expression env sexp =
Typetexp.reset_type_variables();
+ global_stage := 0; (* NNN *)
begin_def();
let exp = type_exp env sexp in
end_def();
if is_nonexpansive exp then generalize exp.exp_type
else generalize_expansive env exp.exp_type;
+ (* NNN The original code
match sexp.pexp_desc with
Pexp_ident lid ->
(* Special case for keeping type variables when looking-up a variable *)
let (path, desc) = Env.lookup_value lid.txt env in
{exp with exp_type = desc.val_type}
| _ -> exp
+ We have to modify it since <x> is also Pexp_ident, with the additional
+ attribute though. So, either we have to check for metaocaml.bracket
+ attribute, or, better, check exp. After type-checking, <x> is no longer
+ Pexp_ident. For ordinary identifiers though, Pexp_ident li maps to
+ Texp_ident (..,li,..) -- with the exception of instance vars, which
+ don't matter at the ttoplevel anyway.
+*)
+ (* NNN new code *)
+ match exp.exp_desc with
+ Texp_ident (_,lid,_) ->
+ (* Special case for keeping type variables when looking-up a variable *)
+ let (path, desc) = Env.lookup_value lid.txt env in
+ {exp with exp_type = desc.val_type}
+ | _ -> exp
+ (* NNN end *)
(* Error report *)
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment