Ekdohibs
/
ocaml
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Fusion des modifs faites sur la branche release jusqu'a la release 3.08.0 

git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@6552 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02
master
Xavier Leroy 2004-07-13 12:19:15 +00:00
parent 960111fea4
commit 237006931a
81 changed files with 1392 additions and 9633 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

82
.depend
View File

@ -267,8 +267,8 @@ bytecomp/instruct.cmi: typing/env.cmi typing/ident.cmi bytecomp/lambda.cmi \
typing/types.cmi
bytecomp/lambda.cmi: parsing/asttypes.cmi typing/env.cmi typing/ident.cmi \
typing/path.cmi typing/primitive.cmi typing/types.cmi
bytecomp/matching.cmi: typing/ident.cmi bytecomp/lambda.cmi \
parsing/location.cmi typing/typedtree.cmi
bytecomp/matching.cmi: parsing/asttypes.cmi typing/ident.cmi \
bytecomp/lambda.cmi parsing/location.cmi typing/typedtree.cmi
bytecomp/printinstr.cmi: bytecomp/instruct.cmi
bytecomp/printlambda.cmi: bytecomp/lambda.cmi
bytecomp/simplif.cmi: bytecomp/lambda.cmi
@ -377,18 +377,18 @@ bytecomp/symtable.cmx: parsing/asttypes.cmi bytecomp/bytesections.cmx \
utils/clflags.cmx bytecomp/dll.cmx bytecomp/emitcode.cmx typing/ident.cmx \
bytecomp/lambda.cmx bytecomp/meta.cmx utils/misc.cmx typing/predef.cmx \
bytecomp/runtimedef.cmx utils/tbl.cmx bytecomp/symtable.cmi
bytecomp/translclass.cmo: parsing/asttypes.cmi utils/clflags.cmo \
typing/ctype.cmi typing/env.cmi typing/ident.cmi bytecomp/lambda.cmi \
parsing/location.cmi bytecomp/matching.cmi utils/misc.cmi typing/path.cmi \
bytecomp/translcore.cmi bytecomp/translobj.cmi typing/typeclass.cmi \
typing/typedtree.cmi bytecomp/typeopt.cmi typing/types.cmi \
bytecomp/translclass.cmi
bytecomp/translclass.cmx: parsing/asttypes.cmi utils/clflags.cmx \
typing/ctype.cmx typing/env.cmx typing/ident.cmx bytecomp/lambda.cmx \
parsing/location.cmx bytecomp/matching.cmx utils/misc.cmx typing/path.cmx \
bytecomp/translcore.cmx bytecomp/translobj.cmx typing/typeclass.cmx \
typing/typedtree.cmx bytecomp/typeopt.cmx typing/types.cmx \
bytecomp/translclass.cmi
bytecomp/translclass.cmo: parsing/asttypes.cmi typing/btype.cmi \
utils/clflags.cmo typing/ctype.cmi typing/env.cmi typing/ident.cmi \
bytecomp/lambda.cmi parsing/location.cmi bytecomp/matching.cmi \
utils/misc.cmi typing/path.cmi bytecomp/translcore.cmi \
bytecomp/translobj.cmi typing/typeclass.cmi typing/typedtree.cmi \
bytecomp/typeopt.cmi typing/types.cmi bytecomp/translclass.cmi
bytecomp/translclass.cmx: parsing/asttypes.cmi typing/btype.cmx \
utils/clflags.cmx typing/ctype.cmx typing/env.cmx typing/ident.cmx \
bytecomp/lambda.cmx parsing/location.cmx bytecomp/matching.cmx \
utils/misc.cmx typing/path.cmx bytecomp/translcore.cmx \
bytecomp/translobj.cmx typing/typeclass.cmx typing/typedtree.cmx \
bytecomp/typeopt.cmx typing/types.cmx bytecomp/translclass.cmi
bytecomp/translcore.cmo: parsing/asttypes.cmi typing/btype.cmi \
utils/clflags.cmo utils/config.cmi typing/env.cmi typing/ident.cmi \
bytecomp/lambda.cmi parsing/location.cmi bytecomp/matching.cmi \
@ -413,11 +413,13 @@ bytecomp/translmod.cmx: parsing/asttypes.cmi utils/config.cmx \
typing/predef.cmx typing/primitive.cmx typing/printtyp.cmx \
bytecomp/translclass.cmx bytecomp/translcore.cmx bytecomp/translobj.cmx \
typing/typedtree.cmx typing/types.cmx bytecomp/translmod.cmi
bytecomp/translobj.cmo: parsing/asttypes.cmi typing/env.cmi typing/ident.cmi \
bytecomp/lambda.cmi parsing/longident.cmi utils/misc.cmi \
bytecomp/translobj.cmo: parsing/asttypes.cmi typing/btype.cmi \
utils/clflags.cmo typing/env.cmi typing/ident.cmi bytecomp/lambda.cmi \
parsing/longident.cmi utils/misc.cmi typing/primitive.cmi \
bytecomp/translobj.cmi
bytecomp/translobj.cmx: parsing/asttypes.cmi typing/env.cmx typing/ident.cmx \
bytecomp/lambda.cmx parsing/longident.cmx utils/misc.cmx \
bytecomp/translobj.cmx: parsing/asttypes.cmi typing/btype.cmx \
utils/clflags.cmx typing/env.cmx typing/ident.cmx bytecomp/lambda.cmx \
parsing/longident.cmx utils/misc.cmx typing/primitive.cmx \
bytecomp/translobj.cmi
bytecomp/typeopt.cmo: parsing/asttypes.cmi typing/ctype.cmi typing/env.cmi \
typing/ident.cmi bytecomp/lambda.cmi utils/misc.cmi typing/path.cmi \
@ -432,8 +434,8 @@ asmcomp/asmlink.cmi: asmcomp/compilenv.cmi
asmcomp/clambda.cmi: parsing/asttypes.cmi typing/ident.cmi \
bytecomp/lambda.cmi
asmcomp/closure.cmi: asmcomp/clambda.cmi bytecomp/lambda.cmi
asmcomp/cmmgen.cmi: asmcomp/clambda.cmi asmcomp/cmm.cmi
asmcomp/cmm.cmi: typing/ident.cmi
asmcomp/cmmgen.cmi: asmcomp/clambda.cmi asmcomp/cmm.cmi
asmcomp/codegen.cmi: asmcomp/cmm.cmi
asmcomp/comballoc.cmi: asmcomp/mach.cmi
asmcomp/compilenv.cmi: asmcomp/clambda.cmi typing/ident.cmi
@ -447,8 +449,8 @@ asmcomp/printlinear.cmi: asmcomp/linearize.cmi
asmcomp/printmach.cmi: asmcomp/mach.cmi asmcomp/reg.cmi
asmcomp/proc.cmi: asmcomp/mach.cmi asmcomp/reg.cmi
asmcomp/reg.cmi: asmcomp/cmm.cmi
asmcomp/reloadgen.cmi: asmcomp/mach.cmi asmcomp/reg.cmi
asmcomp/reload.cmi: asmcomp/mach.cmi
asmcomp/reloadgen.cmi: asmcomp/mach.cmi asmcomp/reg.cmi
asmcomp/schedgen.cmi: asmcomp/linearize.cmi asmcomp/mach.cmi
asmcomp/scheduling.cmi: asmcomp/linearize.cmi
asmcomp/selectgen.cmi: asmcomp/arch.cmo asmcomp/cmm.cmi typing/ident.cmi \
@ -512,6 +514,8 @@ asmcomp/closure.cmx: parsing/asttypes.cmi asmcomp/clambda.cmx \
utils/clflags.cmx asmcomp/compilenv.cmx typing/ident.cmx \
bytecomp/lambda.cmx utils/misc.cmx typing/primitive.cmx \
bytecomp/switch.cmx utils/tbl.cmx asmcomp/closure.cmi
asmcomp/cmm.cmo: asmcomp/arch.cmo typing/ident.cmi asmcomp/cmm.cmi
asmcomp/cmm.cmx: asmcomp/arch.cmx typing/ident.cmx asmcomp/cmm.cmi
asmcomp/cmmgen.cmo: asmcomp/arch.cmo parsing/asttypes.cmi asmcomp/clambda.cmi \
utils/clflags.cmo asmcomp/cmm.cmi asmcomp/compilenv.cmi utils/config.cmi \
typing/ident.cmi bytecomp/lambda.cmi utils/misc.cmi typing/primitive.cmi \
@ -520,8 +524,6 @@ asmcomp/cmmgen.cmx: asmcomp/arch.cmx parsing/asttypes.cmi asmcomp/clambda.cmx \
utils/clflags.cmx asmcomp/cmm.cmx asmcomp/compilenv.cmx utils/config.cmx \
typing/ident.cmx bytecomp/lambda.cmx utils/misc.cmx typing/primitive.cmx \
asmcomp/proc.cmx bytecomp/switch.cmx typing/types.cmx asmcomp/cmmgen.cmi
asmcomp/cmm.cmo: asmcomp/arch.cmo typing/ident.cmi asmcomp/cmm.cmi
asmcomp/cmm.cmx: asmcomp/arch.cmx typing/ident.cmx asmcomp/cmm.cmi
asmcomp/codegen.cmo: asmcomp/cmm.cmi asmcomp/coloring.cmi asmcomp/emit.cmi \
asmcomp/interf.cmi asmcomp/linearize.cmi asmcomp/liveness.cmi \
asmcomp/printcmm.cmi asmcomp/printlinear.cmi asmcomp/printmach.cmi \
@ -542,16 +544,16 @@ asmcomp/compilenv.cmo: asmcomp/clambda.cmi utils/config.cmi typing/env.cmi \
typing/ident.cmi utils/misc.cmi asmcomp/compilenv.cmi
asmcomp/compilenv.cmx: asmcomp/clambda.cmx utils/config.cmx typing/env.cmx \
typing/ident.cmx utils/misc.cmx asmcomp/compilenv.cmi
asmcomp/emit.cmo: asmcomp/arch.cmo asmcomp/cmm.cmi asmcomp/compilenv.cmi \
utils/config.cmi asmcomp/emitaux.cmi asmcomp/linearize.cmi \
parsing/location.cmi asmcomp/mach.cmi utils/misc.cmi asmcomp/proc.cmi \
asmcomp/reg.cmi asmcomp/emit.cmi
asmcomp/emit.cmx: asmcomp/arch.cmx asmcomp/cmm.cmx asmcomp/compilenv.cmx \
utils/config.cmx asmcomp/emitaux.cmx asmcomp/linearize.cmx \
parsing/location.cmx asmcomp/mach.cmx utils/misc.cmx asmcomp/proc.cmx \
asmcomp/reg.cmx asmcomp/emit.cmi
asmcomp/emitaux.cmo: asmcomp/emitaux.cmi
asmcomp/emitaux.cmx: asmcomp/emitaux.cmi
asmcomp/emit.cmo: asmcomp/arch.cmo utils/clflags.cmo asmcomp/cmm.cmi \
asmcomp/compilenv.cmi utils/config.cmi asmcomp/emitaux.cmi \
asmcomp/linearize.cmi parsing/location.cmi asmcomp/mach.cmi \
utils/misc.cmi asmcomp/proc.cmi asmcomp/reg.cmi asmcomp/emit.cmi
asmcomp/emit.cmx: asmcomp/arch.cmx utils/clflags.cmx asmcomp/cmm.cmx \
asmcomp/compilenv.cmx utils/config.cmx asmcomp/emitaux.cmx \
asmcomp/linearize.cmx parsing/location.cmx asmcomp/mach.cmx \
utils/misc.cmx asmcomp/proc.cmx asmcomp/reg.cmx asmcomp/emit.cmi
asmcomp/interf.cmo: asmcomp/mach.cmi utils/misc.cmi asmcomp/proc.cmi \
asmcomp/reg.cmi asmcomp/interf.cmi
asmcomp/interf.cmx: asmcomp/mach.cmx utils/misc.cmx asmcomp/proc.cmx \
@ -588,20 +590,20 @@ asmcomp/proc.cmx: asmcomp/arch.cmx utils/ccomp.cmx utils/clflags.cmx \
asmcomp/reg.cmx asmcomp/proc.cmi
asmcomp/reg.cmo: asmcomp/cmm.cmi asmcomp/reg.cmi
asmcomp/reg.cmx: asmcomp/cmm.cmx asmcomp/reg.cmi
asmcomp/reload.cmo: asmcomp/reloadgen.cmi asmcomp/reload.cmi
asmcomp/reload.cmx: asmcomp/reloadgen.cmx asmcomp/reload.cmi
asmcomp/reloadgen.cmo: asmcomp/mach.cmi utils/misc.cmi asmcomp/reg.cmi \
asmcomp/reloadgen.cmi
asmcomp/reloadgen.cmx: asmcomp/mach.cmx utils/misc.cmx asmcomp/reg.cmx \
asmcomp/reloadgen.cmi
asmcomp/reload.cmo: asmcomp/arch.cmo asmcomp/cmm.cmi asmcomp/mach.cmi \
asmcomp/reg.cmi asmcomp/reloadgen.cmi asmcomp/reload.cmi
asmcomp/reload.cmx: asmcomp/arch.cmx asmcomp/cmm.cmx asmcomp/mach.cmx \
asmcomp/reg.cmx asmcomp/reloadgen.cmx asmcomp/reload.cmi
asmcomp/schedgen.cmo: asmcomp/arch.cmo asmcomp/cmm.cmi asmcomp/linearize.cmi \
asmcomp/mach.cmi utils/misc.cmi asmcomp/reg.cmi asmcomp/schedgen.cmi
asmcomp/schedgen.cmx: asmcomp/arch.cmx asmcomp/cmm.cmx asmcomp/linearize.cmx \
asmcomp/mach.cmx utils/misc.cmx asmcomp/reg.cmx asmcomp/schedgen.cmi
asmcomp/scheduling.cmo: asmcomp/schedgen.cmi asmcomp/scheduling.cmi
asmcomp/scheduling.cmx: asmcomp/schedgen.cmx asmcomp/scheduling.cmi
asmcomp/scheduling.cmo: asmcomp/arch.cmo asmcomp/mach.cmi \
asmcomp/schedgen.cmi asmcomp/scheduling.cmi
asmcomp/scheduling.cmx: asmcomp/arch.cmx asmcomp/mach.cmx \
asmcomp/schedgen.cmx asmcomp/scheduling.cmi
asmcomp/selectgen.cmo: asmcomp/arch.cmo asmcomp/cmm.cmi typing/ident.cmi \
asmcomp/mach.cmi utils/misc.cmi asmcomp/proc.cmi asmcomp/reg.cmi \
utils/tbl.cmi asmcomp/selectgen.cmi
@ -609,10 +611,10 @@ asmcomp/selectgen.cmx: asmcomp/arch.cmx asmcomp/cmm.cmx typing/ident.cmx \
asmcomp/mach.cmx utils/misc.cmx asmcomp/proc.cmx asmcomp/reg.cmx \
utils/tbl.cmx asmcomp/selectgen.cmi
asmcomp/selection.cmo: asmcomp/arch.cmo asmcomp/cmm.cmi asmcomp/mach.cmi \
utils/misc.cmi asmcomp/proc.cmi asmcomp/reg.cmi asmcomp/selectgen.cmi \
utils/misc.cmi asmcomp/reg.cmi asmcomp/selectgen.cmi \
asmcomp/selection.cmi
asmcomp/selection.cmx: asmcomp/arch.cmx asmcomp/cmm.cmx asmcomp/mach.cmx \
utils/misc.cmx asmcomp/proc.cmx asmcomp/reg.cmx asmcomp/selectgen.cmx \
utils/misc.cmx asmcomp/reg.cmx asmcomp/selectgen.cmx \
asmcomp/selection.cmi
asmcomp/spill.cmo: asmcomp/mach.cmi utils/misc.cmi asmcomp/proc.cmi \
asmcomp/reg.cmi asmcomp/spill.cmi
@ -652,8 +654,6 @@ driver/errors.cmx: bytecomp/bytelibrarian.cmx bytecomp/bytelink.cmx \
typing/typeclass.cmx typing/typecore.cmx typing/typedecl.cmx \
typing/typemod.cmx typing/typetexp.cmx utils/warnings.cmx \
driver/errors.cmi
driver/main_args.cmo: driver/main_args.cmi
driver/main_args.cmx: driver/main_args.cmi
driver/main.cmo: bytecomp/bytelibrarian.cmi bytecomp/bytelink.cmi \
bytecomp/bytepackager.cmi utils/clflags.cmo driver/compile.cmi \
utils/config.cmi driver/errors.cmi driver/main_args.cmi utils/misc.cmi \
@ -662,6 +662,8 @@ driver/main.cmx: bytecomp/bytelibrarian.cmx bytecomp/bytelink.cmx \
bytecomp/bytepackager.cmx utils/clflags.cmx driver/compile.cmx \
utils/config.cmx driver/errors.cmx driver/main_args.cmx utils/misc.cmx \
utils/warnings.cmx driver/main.cmi
driver/main_args.cmo: driver/main_args.cmi
driver/main_args.cmx: driver/main_args.cmi
driver/optcompile.cmo: asmcomp/asmgen.cmi utils/ccomp.cmi utils/clflags.cmo \
asmcomp/compilenv.cmi utils/config.cmi typing/env.cmi typing/ident.cmi \
utils/misc.cmi parsing/parse.cmi driver/pparse.cmi parsing/printast.cmi \

12
Changes
View File

@ -5,7 +5,7 @@ Objective Caml 3.08:
Language features:
- Support for immediate objects, i.e. objects defined without going
through a class. (Syntax is "object <field and methods> end".)
through a class. (Syntax is "object <fields and methods> end".)
Type-checking:
- When typing record construction and record patterns, can omit
@ -16,19 +16,19 @@ Both compilers:
- More compact compilation of classes.
- Much more efficient handling of class definitions inside functors
or local modules.
- Simpler represention for method tables. Objects can now be marshalled
- Simpler representation for method tables. Objects can now be marshaled
between identical programs with the flag Marshal.Closures.
- Improved error messages for objects and variants.
- Improved printing of inferred module signatures (toplevel and ocamlc -i).
Recursion between type, class, class type and module definitions is now
correctly printed.
- The -pack option now accepts compiled interfaces (.cmi files) in addition
to compiled implementations.
to compiled implementations (.cmo or .cmx).
* A compile-time error is signaled if an integer literal exceeds the
range of representable integers.
- Fixed code generation error for "module rec" definitions.
- The combination of options -c -o sets the name of the generated
.cm[iox] files.
.cmi / .cmo / .cmx files.
Bytecode compiler:
- Option -output-obj is now compatible with Dynlink and
@ -67,8 +67,10 @@ Other libraries:
- The Num library: complete reimplementation of the C/asm lowest
layer to work around potential licensing problems.
Improved speed on the PowerPC and AMD64 architectures.
- The Graphics library: improved event handling under MS Windows.
- The Str library: fixed bug in "split" functions with nullable regexps.
- The Unix library:
. Added Unix.single_write.
. Added support for IPv6.
. Bug fixes in Unix.closedir.
. Allow thread switching on Unix.lockf.
@ -130,7 +132,7 @@ Type-checking:
type of any subexpression in the source file. Works even in the case
of a type error (all the types computed up to the error are available).
This new feature is also supported by ocamlbrowser.
- Disable "method is overriden" warning when the method was explicitely
- Disable "method is overriden" warning when the method was explicitly
redefined as virtual beforehand (i.e. not through inheritance). Typing
and semantics are unchanged.

25
INSTALL
View File

@ -11,7 +11,7 @@ PREREQUISITES
are all *required*. The vendor-provided compiler, assembler and make
have major problems.
* Under MacOS X, before you begin, you must raise the limit on the
* Under MacOS X up to version 10.2.8, you must raise the limit on the
stack size with one of the following commands:
limit stacksize 64M # if your shell is zsh or tcsh
@ -84,6 +84,23 @@ The "configure" script accepts the following options:
-no-pthread
Do not attempt to use POSIX threads.
-with-pthread
Attempt to use POSIX threads (this is the default).
-no-shared-libs
Do not configure support for shared libraries
-dldefs <cpp flags>
-dllibs <flags and libraries>
These options specify where to find the libraries for dynamic
linking (i.e. use of shared libraries). "-dldefs" specifies
options for finding the header files, and "-dllibs" for finding
the C libraries.
-binutils <directory>
This option specifies where to find the GNU binutils (objcopy
and nm) executables.
-verbose
Verbose output of the configuration tests. Use it if the outcome
of configure is not what you were expecting.
@ -245,10 +262,14 @@ COMMON PROBLEMS:
* The Makefiles use the "include" directive, which is not supported by
all versions of make. Use GNU make if this is a problem.
* The Makefiles assume that make execute commands by calling /bin/sh. They
* The Makefiles assume that make executes commands by calling /bin/sh. They
won't work if /bin/csh is called instead. You may have to unset the SHELL
environment variable, or set it to /bin/sh.
* On some systems, localization causes build problems. You should
try to set the C locale (export LC_ALL=C) before compiling if you have
strange errors while compiling OCaml.
* gcc 2.7.2.1 generates incorrect code for the runtime system in -O mode
on some Intel x86 platforms (e.g. Linux RedHat 4.1 and 4.2).
If this causes a problem, the solution is to upgrade to 2.7.2.3 or above.

56
README
View File

@ -8,10 +8,10 @@ Objective Caml comprises two compilers. One generates bytecode
which is then interpreted by a C program. This compiler runs quickly,
generates compact code with moderate memory requirements, and is
portable to essentially any 32 or 64 bit Unix platform. Performance of
generated programs is quite good for a bytecoded implementation:
almost twice as fast as Caml Light 0.7. This compiler can be used
either as a standalone, batch-oriented compiler that produces
standalone programs, or as an interactive, toplevel-based system.
generated programs is quite good for a bytecoded implementation.
This compiler can be used either as a standalone, batch-oriented
compiler that produces standalone programs, or as an interactive,
toplevel-based system.
The other compiler generates high-performance native code for a number
of processors. Compilation takes longer and generates bigger code, but
@ -19,17 +19,23 @@ the generated programs deliver excellent performance, while retaining
the moderate memory requirements of the bytecode compiler. The
native-code compiler currently runs on the following platforms:
Intel/AMD Pentium processors: PCs under Linux, FreeBSD, NetBSD,
OpenBSD, Windows, NextStep, Solaris 2, BeOS.
PowerPC processors: PowerMacintosh under MacOS X and LinuxPPC.
AMD64 (Opteron) processors: PCs under Linux.
Alpha processors: Digital/Compaq/HP Alpha machines under
Digital Unix/Compaq Tru64, Linux, NetBSD and OpenBSD.
Sparc processors: Sun Sparc machines under Solaris 2, NetBSD, Linux
Mips processors: SGI workstations and mainframes under IRIX 6
Intel IA64 processors: HP stations under Linux
HP PA-RISC processors: HP 9000/700 under HPUX 10 and Linux
Strong ARM processors: Corel Netwinder under Linux
Tier 1 (actively used and maintained by the core Caml team):
AMD64 (Opteron) Linux
IA32 (Pentium) Linux, FreeBSD, MS Windows
PowerPC MacOS X
Tier 2 (maintained but less actively, with help from users):
Alpha Digital Unix/Compaq Tru64, Linux, all BSD
AMD64 FreeBSD, OpenBSD
HP PA-RISC HPUX 11, Linux
IA32 (Pentium) NetBSD, OpenBSD, Solaris 9
IA64 Linux, FreeBSD
MIPS IRIX 6
PowerPC Linux, NetBSD
SPARC Solaris 9, Linux, NetBSD
Strong ARM Linux
Other operating systems for the processors above have not been tested,
but the compiler may work under other operating systems with little work.
@ -43,16 +49,16 @@ CONTENTS:
Changes what's new with each release
INSTALL instructions for installation
INSTALL.MPW infos on the Macintosh MPW port of Objective Caml
LICENSE license and copyright notice
Makefile main Makefile
README this file
README.win32 infos on the MS Windows 98/ME/NT/2000 ports of O.Caml
README.win32 infos on the MS Windows ports of O.Caml
asmcomp/ native-code compiler and linker
asmrun/ native-code runtime library
boot/ bootstrap compiler
bytecomp/ bytecode compiler and linker
byterun/ bytecode interpreter and runtime system
camlp4/ the Camlp4 preprocessor
config/ autoconfiguration stuff
debugger/ source-level replay debugger
driver/ driver code for the compilers
@ -72,7 +78,7 @@ CONTENTS:
COPYRIGHT:
All files marked "Copyright INRIA" in this distribution are copyright
1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003 Institut National de
1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004 Institut National de
Recherche en Informatique et en Automatique (INRIA) and distributed
under the conditions stated in file LICENSE.
@ -80,7 +86,6 @@ INSTALLATION:
See the file INSTALL for installation instructions on Unix, Linux and
MacOS X machines. For MS Windows, see README.win32.
For the MacOS 7, 8, 9, see INSTALL.MPW.
DOCUMENTATION:
@ -91,23 +96,17 @@ DVI, and Emacs Info files. It is available on the World Wide Web, at
AVAILABILITY:
The complete Objective Caml distribution can be accessed through a Web
browser at
The complete Objective Caml distribution can be accessed at
http://caml.inria.fr/
or by anonymous FTP:
host: ftp.inria.fr
directory: INRIA/caml-light
KEEPING IN TOUCH WITH THE CAML COMMUNITY:
There exists a mailing list of users of the Caml implementations
developed at INRIA. The purpose of this list is to share
experience, exchange ideas (and even code), and report on applications
of the Caml language. Messages can be written in English or in
French. The list has about 500 subscribers.
French. The list has about 750 subscribers.
Messages to the list should be sent to:
@ -119,8 +118,7 @@ If you wish to subscribe to this list, please send a message to:
with the single word "subscribe" in the body of the message.
Archives of the list are available on the World Wide Web at URL
http://caml.inria.fr/
Archives of the list are available on the Web site http://caml.inria.fr/
The Usenet news groups comp.lang.ml and comp.lang.functional
also contains discussions about the ML family of programming languages,

35
README.win32
View File

@ -103,8 +103,7 @@ You will need the following software components to perform the recompilation:
- Windows NT, 2000, or XP (we advise against compiling under Windows 95/98/ME)
- Visual C++ version 6 or 7
- MASM version 6.11 (see above)
- The CygWin port of GNU tools, available from
http://sourceware.cygnus.com/cygwin/
- The Cygwin port of GNU tools, available from http://cygwin.com/
- TCL/TK version 8.3 (for the LablTK GUI) (see above).
Remember to add the directory where the libraries tk83.lib and
@ -176,8 +175,32 @@ available from http://prdownloads.sourceforge.net/tcl/tcl832.exe.
INSTALLATION:
There is no binary distribution yet, so please follow the compilation
instructions below.
The binary distribution is a self-installing executable archive.
Just run it and it should install OCaml automatically.
If you are using Windows 95, 98 or ME, you need to adjust environment
variables as follows:
- add the "bin" subdirectory of the OCaml installation directory
to the PATH variable;
- set the OCAMLLIB variable to the "lib" subdirectory of the
OCaml installation directory.
For instance, if you installed OCaml in C:\Program Files\Objective Caml,
add the following two lines at the end of C:\autoexec.bat:
set PATH=%PATH%;"C:\Program Files\Objective Caml\bin"
set OCAMLLIB=C:\Program Files\Objective Caml\lib
No such tweaking of environment variables is needed under NT, 2000 and XP.
To run programs that use the LablTK GUI, the directory where the
DLLs tk83.dll and tcl83.dll were installed (by the Tcl/Tk
installer) must be added to the PATH environment variable.
To compile programs that use the LablTK GUI, the directory where the
libraries tk83.lib and tcl83.lib were installed (by the Tcl/Tk
installer) must be added to the library search path in the LIB
environment variable. E.g. if Tcl/Tk was installed in C:\tcl, add
"C:\tcl\lib" to the LIB environment variable.
RECOMPILATION FROM THE SOURCES:
@ -236,7 +259,7 @@ This port runs under all versions of MS Windows supported by Cygwin.
INSTALLATION:
For various reasons, no binary distribution of this port is available.
For technical reasons, no binary distribution of this port is available.
You need to recompile from the source distribution.
@ -248,6 +271,6 @@ Just follow the instructions for Unix machines given in the file INSTALL.
NOTES:
The libraries available in this port are "num", "str", "threads",
"unix" and "labltk". "graph" is not available yet.
"unix" and "labltk". "graph" is not available.
The replay debugger is supported.

4
Upgrading
View File

@ -4,7 +4,7 @@
I Installation
Q1: When compiling the distribution, I am getting strange linking
errors in otherlibraries.
errors in "otherlibraries".
A1: This is probably a problem with dynamic linking. You can disable
it with ./configure -no-shared-libs. If you really want to use
@ -91,7 +91,7 @@ A8: The new default mode is more flexible than the original commuting
mode, so that you shouldn't see too much differences when using
labeled libraries. Labels are only compulsory in partial
applications (including the special case of function with an
unkwnown return type), or if you wrote some of them.
unknown return type), or if you wrote some of them.
On the other hand, for definitions, labels present in the
interface must also be present in the implementation.

2
asmcomp/amd64/emit.mlp
View File

@ -606,7 +606,7 @@ let fundecl fundecl =
`{emit_label !range_check_trap}: call {emit_symbol "caml_ml_array_bound_error"}\n`;
(* Never returns, but useful to have retaddr on stack for debugging *)
if !float_constants <> [] then begin
` .section .rodata.cst8,\"aM\",@progbits,8\n`;
` .section .rodata.cst8,\"a\",@progbits\n`;
List.iter emit_float_constant !float_constants
end

3
asmcomp/ia64/emit.mlp
View File

@ -819,7 +819,8 @@ let emit_instr i =
if is_immediate_addl_nat n then "movi" else "movil" in
insimm instr [||] (Nativeint.to_string n) (regs i.res)
| Lop(Iconst_float s) ->
begin match Int64.bits_of_float (float_of_string s) with
let f = float_of_string s in
begin match Int64.bits_of_float f with
| 0x0000_0000_0000_0000L -> (* +0.0 *)
insert "mov" [| "f0" |] (regs i.res)
| 0x3FF0_0000_0000_0000L -> (* 1.0 *)

969
asmrun/.depend
View File

File diff suppressed because it is too large Load Diff

2
asmrun/amd64.S
View File

@ -323,7 +323,7 @@ caml_system__frametable:
.value 0 /* no roots here */
.align 8
.section .rodata.cst8,"aM",@progbits,8
.section .rodata.cst8,"a",@progbits
.globl caml_negf_mask
.type caml_negf_mask,@object
.align 16

2
asmrun/mips.s
View File

@ -96,7 +96,7 @@ caml_call_gc:
s.d $f30, 30 * 8($sp)
s.d $f31, 31 * 8($sp)
/* Call the garbage collector */
jal garbage_collection
jal caml_garbage_collection
/* Restore all regs used by the code generator */
addu $24, $sp, 0x100
lw $2, 2 * 4($24)

BIN
boot/ocamlc
View File

Binary file not shown.

BIN
boot/ocamllex
View File

Binary file not shown.

2
bytecomp/bytegen.ml
View File

@ -644,7 +644,7 @@ let rec comp_expr env exp sz cont =
let (branch, cont1) = make_branch cont in
let c = ref (discard_dead_code cont1) in
(* Build indirection vectors *)
let store = mk_store (=) in
let store = mk_store Lambda.same in
let act_consts = Array.create sw.sw_numconsts 0
and act_blocks = Array.create sw.sw_numblocks 0 in
begin match sw.sw_failaction with (* default is index 0 *)

6
bytecomp/bytelink.ml
View File

@ -264,8 +264,10 @@ let make_absolute file =
(* Create a bytecode executable file *)
let link_bytecode tolink exec_name standalone =
let outchan = open_out_gen [Open_wronly; Open_trunc; Open_creat; Open_binary]
0o777 exec_name in
Misc.remove_file exec_name; (* avoid permission problems, cf PR#1911 *)
let outchan =
open_out_gen [Open_wronly; Open_trunc; Open_creat; Open_binary]
0o777 exec_name in
try
if standalone then begin
(* Copy the header *)

58
bytecomp/lambda.ml
View File

@ -162,6 +162,64 @@ let const_unit = Const_pointer 0
let lambda_unit = Lconst const_unit
let rec same l1 l2 =
match (l1, l2) with
| Lvar v1, Lvar v2 ->
Ident.same v1 v2
| Lconst c1, Lconst c2 ->
c1 = c2
| Lapply(a1, bl1), Lapply(a2, bl2) ->
same a1 a2 && samelist same bl1 bl2
| Lfunction(k1, idl1, a1), Lfunction(k2, idl2, a2) ->
k1 = k2 && samelist Ident.same idl1 idl2 && same a1 a2
| Llet(k1, id1, a1, b1), Llet(k2, id2, a2, b2) ->
k1 = k2 && Ident.same id1 id2 && same a1 a2 && same b1 b2
| Lletrec (bl1, a1), Lletrec (bl2, a2) ->
samelist samebinding bl1 bl2 && same a1 a2
| Lprim(p1, al1), Lprim(p2, al2) ->
p1 = p2 && samelist same al1 al2
| Lswitch(a1, s1), Lswitch(a2, s2) ->
same a1 a2 && sameswitch s1 s2
| Lstaticraise(n1, al1), Lstaticraise(n2, al2) ->
n1 = n2 && samelist same al1 al2
| Lstaticcatch(a1, (n1, idl1), b1), Lstaticcatch(a2, (n2, idl2), b2) ->
same a1 a2 && n1 = n2 && samelist Ident.same idl1 idl2 && same b1 b2
| Ltrywith(a1, id1, b1), Ltrywith(a2, id2, b2) ->
same a1 a2 && Ident.same id1 id2 && same b1 b2
| Lifthenelse(a1, b1, c1), Lifthenelse(a2, b2, c2) ->
same a1 a2 && same b1 b2 && same c1 c2
| Lsequence(a1, b1), Lsequence(a2, b2) ->
same a1 a2 && same b1 b2
| Lwhile(a1, b1), Lwhile(a2, b2) ->
same a1 a2 && same b1 b2
| Lfor(id1, a1, b1, df1, c1), Lfor(id2, a2, b2, df2, c2) ->
Ident.same id1 id2 && same a1 a2 &&
same b1 b2 && df1 = df2 && same c1 c2
| Lassign(id1, a1), Lassign(id2, a2) ->
Ident.same id1 id2 && same a1 a2
| Lsend(k1, a1, b1, cl1), Lsend(k2, a2, b2, cl2) ->
k1 = k2 && same a1 a2 && same b1 b2 && samelist same cl1 cl2
| Levent(a1, ev1), Levent(a2, ev2) ->
same a1 a2 && ev1.lev_pos = ev2.lev_pos
| Lifused(id1, a1), Lifused(id2, a2) ->
Ident.same id1 id2 && same a1 a2
| _, _ ->
false
and samebinding (id1, c1) (id2, c2) =
Ident.same id1 id2 && same c1 c2
and sameswitch sw1 sw2 =
let samecase (n1, a1) (n2, a2) = n1 = n2 && same a1 a2 in
sw1.sw_numconsts = sw2.sw_numconsts &&
sw1.sw_numblocks = sw2.sw_numblocks &&
samelist samecase sw1.sw_consts sw2.sw_consts &&
samelist samecase sw1.sw_blocks sw2.sw_blocks &&
(match (sw1.sw_failaction, sw2.sw_failaction) with
| (None, None) -> true
| (Some a1, Some a2) -> same a1 a2
| _ -> false)
let name_lambda arg fn =
match arg with
Lvar id -> fn id

1
bytecomp/lambda.mli
View File

@ -166,6 +166,7 @@ and lambda_event_kind =
| Lev_after of Types.type_expr
| Lev_function
val same: lambda -> lambda -> bool
val const_unit: structured_constant
val lambda_unit: lambda
val name_lambda: lambda -> (Ident.t -> lambda) -> lambda

27
byterun/.depend
View File

@ -71,8 +71,6 @@ io.o: io.c config.h ../config/m.h ../config/s.h compatibility.h alloc.h \
lexing.o: lexing.c fail.h compatibility.h misc.h config.h ../config/m.h \
../config/s.h mlvalues.h stacks.h memory.h gc.h major_gc.h freelist.h \
minor_gc.h
macintosh.o: macintosh.c misc.h compatibility.h config.h ../config/m.h \
../config/s.h rotatecursor.h mlvalues.h prims.h
main.o: main.c misc.h compatibility.h config.h ../config/m.h \
../config/s.h mlvalues.h sys.h
major_gc.o: major_gc.c compact.h config.h ../config/m.h ../config/s.h \
@ -84,17 +82,16 @@ memory.o: memory.c fail.h compatibility.h misc.h config.h ../config/m.h \
../config/s.h mlvalues.h freelist.h gc.h gc_ctrl.h major_gc.h memory.h \
minor_gc.h signals.h
meta.o: meta.c alloc.h compatibility.h misc.h config.h ../config/m.h \
../config/s.h mlvalues.h fail.h fix_code.h interp.h major_gc.h \
freelist.h memory.h gc.h minor_gc.h prims.h stacks.h
../config/s.h mlvalues.h fail.h fix_code.h interp.h intext.h io.h \
major_gc.h freelist.h memory.h gc.h minor_gc.h prims.h stacks.h
minor_gc.o: minor_gc.c config.h ../config/m.h ../config/s.h \
compatibility.h fail.h misc.h mlvalues.h finalise.h roots.h memory.h \
gc.h major_gc.h freelist.h minor_gc.h gc_ctrl.h signals.h
misc.o: misc.c config.h ../config/m.h ../config/s.h compatibility.h \
misc.h memory.h gc.h mlvalues.h major_gc.h freelist.h minor_gc.h
mpwtool.o: mpwtool.c
obj.o: obj.c alloc.h compatibility.h misc.h config.h ../config/m.h \
../config/s.h mlvalues.h fail.h gc.h major_gc.h freelist.h memory.h \
minor_gc.h prims.h
../config/s.h mlvalues.h fail.h gc.h interp.h major_gc.h freelist.h \
memory.h minor_gc.h prims.h
parsing.o: parsing.c config.h ../config/m.h ../config/s.h compatibility.h \
mlvalues.h misc.h memory.h gc.h major_gc.h freelist.h minor_gc.h \
alloc.h
@ -106,7 +103,6 @@ printexc.o: printexc.c backtrace.h mlvalues.h compatibility.h config.h \
roots.o: roots.c finalise.h roots.h misc.h compatibility.h config.h \
../config/m.h ../config/s.h memory.h gc.h mlvalues.h major_gc.h \
freelist.h minor_gc.h globroots.h stacks.h
rotatecursor.o: rotatecursor.c rotatecursor.h
signals.o: signals.c alloc.h compatibility.h misc.h config.h \
../config/m.h ../config/s.h mlvalues.h callback.h fail.h memory.h gc.h \
major_gc.h freelist.h minor_gc.h roots.h signals.h sys.h
@ -191,7 +187,8 @@ hash.d.o: hash.c mlvalues.h compatibility.h config.h ../config/m.h \
../config/s.h misc.h custom.h memory.h gc.h major_gc.h freelist.h \
minor_gc.h
instrtrace.d.o: instrtrace.c instruct.h misc.h compatibility.h config.h \
../config/m.h ../config/s.h mlvalues.h opnames.h prims.h
../config/m.h ../config/s.h mlvalues.h opnames.h prims.h stacks.h \
memory.h gc.h major_gc.h freelist.h minor_gc.h
intern.d.o: intern.c alloc.h compatibility.h misc.h config.h ../config/m.h \
../config/s.h mlvalues.h custom.h fail.h gc.h intext.h io.h fix_code.h \
memory.h major_gc.h freelist.h minor_gc.h reverse.h
@ -208,8 +205,6 @@ io.d.o: io.c config.h ../config/m.h ../config/s.h compatibility.h alloc.h \
lexing.d.o: lexing.c fail.h compatibility.h misc.h config.h ../config/m.h \
../config/s.h mlvalues.h stacks.h memory.h gc.h major_gc.h freelist.h \
minor_gc.h
macintosh.d.o: macintosh.c misc.h compatibility.h config.h ../config/m.h \
../config/s.h rotatecursor.h mlvalues.h prims.h
main.d.o: main.c misc.h compatibility.h config.h ../config/m.h \
../config/s.h mlvalues.h sys.h
major_gc.d.o: major_gc.c compact.h config.h ../config/m.h ../config/s.h \
@ -221,17 +216,16 @@ memory.d.o: memory.c fail.h compatibility.h misc.h config.h ../config/m.h \
../config/s.h mlvalues.h freelist.h gc.h gc_ctrl.h major_gc.h memory.h \
minor_gc.h signals.h
meta.d.o: meta.c alloc.h compatibility.h misc.h config.h ../config/m.h \
../config/s.h mlvalues.h fail.h fix_code.h interp.h major_gc.h \
freelist.h memory.h gc.h minor_gc.h prims.h stacks.h
../config/s.h mlvalues.h fail.h fix_code.h interp.h intext.h io.h \
major_gc.h freelist.h memory.h gc.h minor_gc.h prims.h stacks.h
minor_gc.d.o: minor_gc.c config.h ../config/m.h ../config/s.h \
compatibility.h fail.h misc.h mlvalues.h finalise.h roots.h memory.h \
gc.h major_gc.h freelist.h minor_gc.h gc_ctrl.h signals.h
misc.d.o: misc.c config.h ../config/m.h ../config/s.h compatibility.h \
misc.h memory.h gc.h mlvalues.h major_gc.h freelist.h minor_gc.h
mpwtool.d.o: mpwtool.c
obj.d.o: obj.c alloc.h compatibility.h misc.h config.h ../config/m.h \
../config/s.h mlvalues.h fail.h gc.h major_gc.h freelist.h memory.h \
minor_gc.h prims.h
../config/s.h mlvalues.h fail.h gc.h interp.h major_gc.h freelist.h \
memory.h minor_gc.h prims.h
parsing.d.o: parsing.c config.h ../config/m.h ../config/s.h compatibility.h \
mlvalues.h misc.h memory.h gc.h major_gc.h freelist.h minor_gc.h \
alloc.h
@ -243,7 +237,6 @@ printexc.d.o: printexc.c backtrace.h mlvalues.h compatibility.h config.h \
roots.d.o: roots.c finalise.h roots.h misc.h compatibility.h config.h \
../config/m.h ../config/s.h memory.h gc.h mlvalues.h major_gc.h \
freelist.h minor_gc.h globroots.h stacks.h
rotatecursor.d.o: rotatecursor.c rotatecursor.h
signals.d.o: signals.c alloc.h compatibility.h misc.h config.h \
../config/m.h ../config/s.h mlvalues.h callback.h fail.h memory.h gc.h \
major_gc.h freelist.h minor_gc.h roots.h signals.h sys.h

1
byterun/compare.c
View File

@ -50,6 +50,7 @@ static void compare_free_stack(void)
/* Same, then raise Out_of_memory */
static void compare_stack_overflow(void)
{
caml_gc_message (0x04, "Stack overflow in structural comparison\n", 0);
compare_free_stack();
caml_raise_out_of_memory();
}

32
byterun/finalise.c
View File

@ -102,7 +102,10 @@ void caml_final_update (void)
}
old = young = j;
to_do_tl->size = k;
for (i = 0; i < k; i++) caml_darken (to_do_tl->item[i++].val, NULL);
for (i = 0; i < k; i++){
CAMLassert (Is_white_val (to_do_tl->item[i].val));
caml_darken (to_do_tl->item[i].val, NULL);
}
}
static int running_finalisation_function = 0;
@ -116,19 +119,22 @@ void caml_final_do_calls (void)
if (running_finalisation_function) return;
while (to_do_hd != NULL && to_do_hd->size == 0){
to_do_hd = to_do_hd->next;
if (to_do_hd == NULL) to_do_tl = NULL;
}
if (to_do_hd != NULL){
Assert (to_do_hd->size > 0);
-- to_do_hd->size;
f = to_do_hd->item[to_do_hd->size];
caml_gc_message (0x80, "Calling finalisation function.\n", 0);
running_finalisation_function = 1;
caml_callback (f.fun, f.val);
running_finalisation_function = 0;
caml_gc_message (0x80, "Return from finalisation function.\n", 0);
caml_gc_message (0x80, "Calling finalisation functions.\n", 0);
while (1){
while (to_do_hd != NULL && to_do_hd->size == 0){
to_do_hd = to_do_hd->next;
if (to_do_hd == NULL) to_do_tl = NULL;
}
if (to_do_hd == NULL) break;
Assert (to_do_hd->size > 0);
-- to_do_hd->size;
f = to_do_hd->item[to_do_hd->size];
running_finalisation_function = 1;
caml_callback (f.fun, f.val);
running_finalisation_function = 0;
}
caml_gc_message (0x80, "Done calling finalisation functions.\n", 0);
}
}

1
byterun/major_gc.c
View File

@ -86,6 +86,7 @@ void caml_darken (value v, value *p /* not used */)
{
if (Is_block (v) && Is_in_heap (v)) {
if (Tag_val(v) == Infix_tag) v -= Infix_offset_val(v);
CAMLassert (!Is_blue_val (v));
if (Is_white_val (v)){
Hd_val (v) = Grayhd_hd (Hd_val (v));
*gray_vals_cur++ = v;

4
byterun/memory.h
View File

@ -60,8 +60,8 @@ color_t caml_allocation_color (void *hp);
#define DEBUG_clear(result, wosize)
#endif
#define Alloc_small(result, wosize, tag) do{ CAMLassert (wosize >= 1); \
CAMLassert ((tag_t) tag < 256); \
#define Alloc_small(result, wosize, tag) do{ CAMLassert ((wosize) >= 1); \
CAMLassert ((tag_t) (tag) < 256); \
CAMLassert ((wosize) <= Max_young_wosize); \
caml_young_ptr -= Bhsize_wosize (wosize); \
if (caml_young_ptr < caml_young_limit){ \

2
byterun/mlvalues.h
View File

@ -187,6 +187,8 @@ typedef opcode_t * code_t;
#define Object_tag 248
#define Class_val(val) Field((val), 0)
#define Oid_val(val) Long_val(Field((val), 1))
CAMLextern value caml_get_public_method (value obj, value tag);
/* called as: callback(caml_get_public_method(obj, hash_variant(name)), obj) */
/* Special case of tuples of fields: closures */
#define Closure_tag 247

2
byterun/startup.c
View File

@ -332,7 +332,7 @@ CAMLexport void caml_main(char **argv)
caml_external_raise = NULL;
/* Determine options and position of bytecode file */
#ifdef DEBUG
caml_verb_gc = 63;
caml_verb_gc = 0xBF;
#endif
parse_camlrunparam();
pos = 0;

13
camlp4/CHANGES
View File

@ -1,4 +1,15 @@
- [12 may 2004] Added to the camlp4 tools the -version option that prints
- [05 Jul 04] creation of the `unmaintained' directory:
pa_format, pa_lefteval, pa_ocamllex, pa_olabl, pa_scheme and pa_sml
go there, each in its own subdir. Currently, they compile fine.
- [05 Jul 04] pa_ifdef, subsumed by pa_macro since 3.07, prints a warning
when loaded, encouraging use of pa_macro.
- [01 July 04] profiled versions of Camlp4 libs are *NOT* installed
by default (not even built). To build and install them, uncomment
the line PROFILING=prof in camlp4/config/Makefile.tpl, and then
make opt.opt && make install
- [22-23 June 04] `make install' now installs also pa_[or].cmx, pa_[or]p.cmx,
pa_[or]_fast.cmx, and odyl.cmx
- [12 may 04] Added to the camlp4 tools the -version option that prints
the version number, in the same way as the other ocaml tools.
- [12 may 04] Locations are now handled as in OCaml. The main benefit
is that line numbers are now correct in error messages. However, this

4
camlp4/Makefile
View File

@ -136,10 +136,8 @@ bootstrap_sources:
sed 's/# $$Id.*\$$/# $(TXTGEN)/' ../../$$i/Makefile | \
sed 's-include ../config-include ../../config-g' | \
sed 's-../boot-../../boot-g' > Makefile; \
sed 's/# $$Id.*\$$/# $(TXTGEN)/' ../../$$i/Makefile.Mac | \
sed 's-:boot-::boot-g' > Makefile.Mac; \
cp ../../$$i/.depend . ; \
cp ../../$$i/Makefile.Mac.depend .); \
); \
done
@-for i in $(FDIRS); do \
(cd $$i; \

4
camlp4/camlp4/.depend
View File

@ -13,10 +13,6 @@ ast2pt.cmx: $(OTOP)/parsing/asttypes.cmi $(OTOP)/parsing/location.cmx \
pcaml.cmx ast2pt.cmi
pcaml.cmo: mLast.cmi quotation.cmi reloc.cmi spretty.cmi pcaml.cmi
pcaml.cmx: mLast.cmi quotation.cmx reloc.cmx spretty.cmx pcaml.cmi
crc.cmo: $(OTOP)/otherlibs/dynlink/dynlink.cmi
crc.cmx: $(OTOP)/otherlibs/dynlink/dynlink.cmx
pcaml.cmo: ast2pt.cmi mLast.cmi quotation.cmi reloc.cmi spretty.cmi pcaml.cmi
pcaml.cmx: ast2pt.cmx mLast.cmi quotation.cmx reloc.cmx spretty.cmx pcaml.cmi
quotation.cmo: mLast.cmi quotation.cmi
quotation.cmx: mLast.cmi quotation.cmi
reloc.cmo: mLast.cmi reloc.cmi

31
camlp4/camlp4/Makefile
View File

@ -18,23 +18,35 @@ CAMLP4=camlp4$(EXE)
CAMLP4OPT=phony
all: $(CAMLP4)
opt: $(OBJS:.cma=.cmxa)
opt: opt$(PROFILING)
optnoprof: $(OBJS:.cma=.cmxa)
optprof: optnoprof $(OBJS:.cma=.p.cmxa)
optp4: $(CAMLP4OPT)
$(CAMLP4): $(OBJS) ../odyl/odyl.cmo
$(OCAMLC) -g $(OBJS) $(CAMLP4M) ../odyl/odyl.cmo -linkall -o $(CAMLP4)
$(OCAMLC) -linkall -o $@ $(OBJS) $(CAMLP4M) ../odyl/odyl.cmo
$(CAMLP4OPT): $(OBJS:.cma=.cmxa) ../odyl/odyl.cmx
$(OCAMLOPT) $(OBJS:.cma=.cmxa) $(CAMLP4M) ../odyl/odyl.cmx -linkall -o $(CAMLP4OPT)
$(OCAMLOPT) -o $@ $(OBJS:.cma=.cmxa) $(CAMLP4M) ../odyl/odyl.cmx
$(OTOP)/utils/config.cmx: $(OTOP)/utils/config.ml
$(OCAMLOPT) -c $(OTOP)/utils/config.ml
$(OCAMLOPT) -I $(OTOP)/utils -c $(OTOP)/utils/config.ml
$(OTOP)/utils/config.p.cmx: $(OTOP)/utils/config.ml
$(OCAMLOPT) -I $(OTOP)/utils -p -c -o $@ $(OTOP)/utils/config.ml
camlp4.cma: $(CAMLP4_OBJS)
$(OCAMLC) $(LINKFLAGS) $(CAMLP4_OBJS) -a -o camlp4.cma
$(OCAMLC) $(LINKFLAGS) -a -o $@ $(CAMLP4_OBJS)
camlp4.cmxa: $(CAMLP4_XOBJS)
$(OCAMLOPT) $(LINKFLAGS) $(CAMLP4_XOBJS) -a -o camlp4.cmxa
$(OCAMLOPT) $(LINKFLAGS) -a -o $@ $(CAMLP4_XOBJS)
camlp4.p.cmxa: $(CAMLP4_XOBJS:.cmx=.p.cmx)
$(OCAMLOPT) $(LINKFLAGS) -a -o $@ $(CAMLP4_XOBJS:.cmx=.p.cmx)
clean::
rm -f *.cm* *.pp[io] *.$(O) *.$(A) *.bak .*.bak *.out *.opt
@ -63,9 +75,8 @@ install:
cp mLast.mli quotation.mli ast2pt.mli pcaml.mli spretty.mli "$(LIBDIR)/camlp4/."
cp mLast.cmi quotation.cmi ast2pt.cmi pcaml.cmi spretty.cmi "$(LIBDIR)/camlp4/."
cp camlp4.cma $(LIBDIR)/camlp4/.
if [ -f camlp4.cmxa ]; \
then cp camlp4.cmxa camlp4.$(A) $(LIBDIR)/camlp4/.; \
else : ; \
fi
for f in camlp4.$(A) camlp4.p.$(A) camlp4.cmxa camlp4.p.cmxa; do \
test -f $$f && cp $$f "$(LIBDIR)/camlp4/." || true; \
done
include .depend

2
camlp4/camlp4/argl.ml
View File

@ -424,7 +424,7 @@ value go () =
report_error exc;
Format.close_box ();
Format.print_newline ();
exit 2
raise exc
}
}
;

14
camlp4/camlp4/pcaml.ml
View File

@ -201,6 +201,19 @@ value handle_patt_locate loc x = handle_locate loc patt_eoi patt_anti x;
value expr_reloc = Reloc.expr;
value patt_reloc = Reloc.patt;
value ctyp_reloc = Reloc.ctyp;
value row_field_reloc = Reloc.row_field;
value class_infos_reloc = Reloc.class_infos;
value module_type_reloc = Reloc.module_type;
value sig_item_reloc = Reloc.sig_item;
value with_constr_reloc = Reloc.with_constr;
value module_expr_reloc = Reloc.module_expr;
value str_item_reloc = Reloc.str_item;
value class_type_reloc = Reloc.class_type;
value class_sig_item_reloc = Reloc.class_sig_item;
value class_expr_reloc = Reloc.class_expr;
value class_str_item_reloc = Reloc.class_str_item;
value rename_id = ref (fun x -> x);
value find_line (bp, ep) str =
@ -368,7 +381,6 @@ value report_error exn =
;
value no_constructors_arity = ref False;
(*value no_assert = ref False;*)
value arg_spec_list_ref = ref [];
value arg_spec_list () = arg_spec_list_ref.val;

23
camlp4/camlp4/pcaml.mli
View File

@ -76,9 +76,6 @@ value add_option : string -> Arg.spec -> string -> unit;
(** Add an option to the command line options. *)
value no_constructors_arity : ref bool;
(** [True]: dont generate constructor arity. *)
(*value no_assert : ref bool;
(** [True]: dont generate assertion checks. *)
*)
value sync : ref (Stream.t char -> unit);
@ -88,10 +85,22 @@ value handle_expr_locate : MLast.loc -> (Lexing.position * string) -> MLast.expr
value handle_patt_quotation : MLast.loc -> (string * string) -> MLast.patt;
value handle_patt_locate : MLast.loc -> (Lexing.position * string) -> MLast.patt;
value expr_reloc :
(MLast.loc -> MLast.loc) -> Lexing.position -> MLast.expr -> MLast.expr;
value patt_reloc :
(MLast.loc -> MLast.loc) -> Lexing.position -> MLast.patt -> MLast.patt;
(** Relocation functions for abstract syntax trees *)
value expr_reloc : (MLast.loc -> MLast.loc) -> Lexing.position -> MLast.expr -> MLast.expr;
value patt_reloc : (MLast.loc -> MLast.loc) -> Lexing.position -> MLast.patt -> MLast.patt;
value ctyp_reloc : (MLast.loc -> MLast.loc) -> 'a -> MLast.ctyp -> MLast.ctyp;
value row_field_reloc : (MLast.loc -> MLast.loc) -> 'a -> MLast.row_field -> MLast.row_field;
value class_infos_reloc : ((MLast.loc -> MLast.loc) -> 'a -> 'b -> 'c) -> (MLast.loc -> MLast.loc) -> 'a -> MLast.class_infos 'b -> MLast.class_infos 'c;
value module_type_reloc : (MLast.loc -> MLast.loc) -> Lexing.position -> MLast.module_type -> MLast.module_type;
value sig_item_reloc : (MLast.loc -> MLast.loc) -> Lexing.position -> MLast.sig_item -> MLast.sig_item;
value with_constr_reloc : (MLast.loc -> MLast.loc) -> Lexing.position -> MLast.with_constr -> MLast.with_constr;
value module_expr_reloc : (MLast.loc -> MLast.loc) -> Lexing.position -> MLast.module_expr -> MLast.module_expr;
value str_item_reloc : (MLast.loc -> MLast.loc) -> Lexing.position -> MLast.str_item -> MLast.str_item;
value class_type_reloc : (MLast.loc -> MLast.loc) -> Lexing.position -> MLast.class_type -> MLast.class_type;
value class_sig_item_reloc : (MLast.loc -> MLast.loc) -> Lexing.position -> MLast.class_sig_item -> MLast.class_sig_item;
value class_expr_reloc : (MLast.loc -> MLast.loc) -> Lexing.position -> MLast.class_expr -> MLast.class_expr;
value class_str_item_reloc : (MLast.loc -> MLast.loc) -> Lexing.position -> MLast.class_str_item -> MLast.class_str_item;
(** To possibly rename identifiers; parsers may call this function
when generating their identifiers; default = identity *)

17
camlp4/camlp4/reloc.mli
View File

@ -16,5 +16,18 @@ value zero_loc : Lexing.position;
value shift_pos : int -> Lexing.position -> Lexing.position;
value adjust_loc : Lexing.position -> MLast.loc -> MLast.loc;
value linearize : MLast.loc -> MLast.loc;
value patt : (MLast.loc -> MLast.loc) -> Lexing.position -> MLast.patt -> MLast.patt;
value expr : (MLast.loc -> MLast.loc) -> Lexing.position -> MLast.expr -> MLast.expr;
value ctyp : (MLast.loc -> MLast.loc) -> 'a -> MLast.ctyp -> MLast.ctyp;
value row_field : (MLast.loc -> MLast.loc) -> 'a -> MLast.row_field -> MLast.row_field;
value class_infos : ((MLast.loc -> MLast.loc) -> 'a -> 'b -> 'c) -> (MLast.loc -> MLast.loc) -> 'a -> MLast.class_infos 'b -> MLast.class_infos 'c;
value patt : (MLast.loc -> MLast.loc) -> Lexing.position -> MLast.patt -> MLast.patt;
value expr : (MLast.loc -> MLast.loc) -> Lexing.position -> MLast.expr -> MLast.expr;
value module_type : (MLast.loc -> MLast.loc) -> Lexing.position -> MLast.module_type -> MLast.module_type;
value sig_item : (MLast.loc -> MLast.loc) -> Lexing.position -> MLast.sig_item -> MLast.sig_item;
value with_constr : (MLast.loc -> MLast.loc) -> Lexing.position -> MLast.with_constr -> MLast.with_constr;
value module_expr : (MLast.loc -> MLast.loc) -> Lexing.position -> MLast.module_expr -> MLast.module_expr;
value str_item : (MLast.loc -> MLast.loc) -> Lexing.position -> MLast.str_item -> MLast.str_item;
value class_type : (MLast.loc -> MLast.loc) -> Lexing.position -> MLast.class_type -> MLast.class_type;
value class_sig_item : (MLast.loc -> MLast.loc) -> Lexing.position -> MLast.class_sig_item -> MLast.class_sig_item;
value class_expr : (MLast.loc -> MLast.loc) -> Lexing.position -> MLast.class_expr -> MLast.class_expr;
value class_str_item : (MLast.loc -> MLast.loc) -> Lexing.position -> MLast.class_str_item -> MLast.class_str_item;

2
camlp4/compile/.depend
View File

@ -2,3 +2,5 @@ comp_trail.cmo: ../camlp4/pcaml.cmi
comp_trail.cmx: ../camlp4/pcaml.cmx
compile.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi
compile.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx
pa_o_fast.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi
pa_o_fast.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx

3
camlp4/compile/Makefile
View File

@ -29,7 +29,8 @@ $D_fast.ml: compile.cmo $(SRC)
OTOP=$(OTOP) EXE=$(EXE) ./compile.sh $(COMP_OPT) $(SRC) > $D_fast.ml
install:
if test -f camlp4o.fast.opt; then cp camlp4o.fast.opt $(BINDIR)/camlp4o.opt$(EXE); fi
if test -f camlp4$D.fast.opt; then cp camlp4$D.fast.opt $(BINDIR)/camlp4$D.opt$(EXE); fi
for TARG in pa_$D_fast.cmi pa_$D_fast.cmo pa_$D_fast.cmx ; do if test -f $$TARG; then cp $$TARG "$(LIBDIR)/camlp4/."; fi; done
clean::
rm -f *.cm* *.pp[io] *.o *.bak .*.bak *.out *.opt

28
camlp4/config/Makefile.tpl
View File

@ -1,28 +1,48 @@
# $Id$
# Change the value of PROFILING to prof for systematically building
# and installing profiled versions of Camlp4 libraries. Then, execute
# `make opt.opt', then `make install' in the OCaml toplevel directory
# (or in the camlp4 subdirectory).
# Default value is noprof
#PROFILING=prof
PROFILING=noprof
###########################################################################
CAMLP4_COMM=OTOP=$(OTOP) OPT=$(OPT) EXE=$(EXE) ../tools/camlp4_comm.sh
OCAMLC=@OTOP=$(OTOP) OPT=$(OPT) EXE=$(EXE) ../tools/ocamlc.sh
OCAMLOPT=@OTOP=$(OTOP) OPT=$(OPT) EXE=$(EXE) ../tools/ocamlopt.sh
OCAMLCFLAGS=
MKDIR=mkdir -p
.SUFFIXES: .cmx .cmo .cmi .ml .mli
TEST_DIRECTORY=test `basename "$<"` = "$<" || { echo "You are not in the right directory"; exit 1; }
.SUFFIXES: .cmx .cmo .cmi .ml .mli .p.cmx
.mli.cmi:
@if test `basename $<` != $<; then echo "Bad directory"; exit 1; fi
@$(TEST_DIRECTORY)
@$(CAMLP4_COMM) $< -o $*.ppi
$(OCAMLC) $(OCAMLCFLAGS) -c -intf $*.ppi
rm -f $*.ppi
.ml.cmo:
@if test `basename $<` != $<; then echo "Bad directory"; exit 1; fi
@$(TEST_DIRECTORY)
@$(CAMLP4_COMM) $< -o $*.ppo
$(OCAMLC) $(OCAMLCFLAGS) -c -impl $*.ppo
rm -f $*.ppo
.ml.cmx:
@if test `basename $<` != $<; then echo "Bad directory"; exit 1; fi
@$(TEST_DIRECTORY)
@$(CAMLP4_COMM) $< -o $*.ppo
$(OCAMLOPT) $(OCAMLCFLAGS) -c -impl $*.ppo
rm -f $*.ppo
.ml.p.cmx:
@$(TEST_DIRECTORY)
@$(CAMLP4_COMM) $< -o $*.ppo
$(OCAMLOPT) $(OCAMLCFLAGS) -c -p -o $*.p.cmx -impl $*.ppo
rm -f $*.ppo

28
camlp4/etc/.depend
View File

@ -3,40 +3,18 @@ pa_extfold.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi
pa_extfold.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx
pa_extfun.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi
pa_extfun.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx
pa_format.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi
pa_format.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx
pa_fstream.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi
pa_fstream.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx
pa_ifdef.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi
pa_ifdef.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx
pa_lefteval.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi
pa_lefteval.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx
pa_lispr.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi ../camlp4/reloc.cmi
pa_lispr.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx ../camlp4/reloc.cmx
pa_lisp.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi
pa_lisp.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx
pa_lispr.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi
pa_lispr.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx
pa_o.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi
pa_o.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx
pa_ocamllex.cmo: $(OTOP)/lex/compact.cmi $(OTOP)/lex/cset.cmi \
$(OTOP)/lex/lexgen.cmi ../camlp4/mLast.cmi ../camlp4/pcaml.cmi \
$(OTOP)/lex/syntax.cmi
pa_ocamllex.cmx: $(OTOP)/lex/compact.cmx $(OTOP)/lex/cset.cmx \
$(OTOP)/lex/lexgen.cmx ../camlp4/mLast.cmi ../camlp4/pcaml.cmx \
$(OTOP)/lex/syntax.cmx
pa_olabl.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi
pa_olabl.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx
pa_oop.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi
pa_oop.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx
pa_op.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi
pa_op.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx
pa_ru.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi
pa_ru.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx
pa_schemer.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi ../camlp4/reloc.cmi
pa_schemer.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx ../camlp4/reloc.cmx
pa_sml.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi
pa_sml.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx
parserify.cmo: ../camlp4/mLast.cmi parserify.cmi
parserify.cmx: ../camlp4/mLast.cmi parserify.cmi
pr_depend.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi
@ -63,11 +41,5 @@ pr_rp_main.cmo: ../camlp4/mLast.cmi parserify.cmi ../camlp4/pcaml.cmi \
../camlp4/spretty.cmi
pr_rp_main.cmx: ../camlp4/mLast.cmi parserify.cmx ../camlp4/pcaml.cmx \
../camlp4/spretty.cmx
pr_scheme.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi
pr_scheme.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx
pr_schp_main.cmo: ../camlp4/mLast.cmi parserify.cmi ../camlp4/pcaml.cmi \
pr_scheme.cmo
pr_schp_main.cmx: ../camlp4/mLast.cmi parserify.cmx ../camlp4/pcaml.cmx \
pr_scheme.cmx
q_phony.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi ../camlp4/quotation.cmi
q_phony.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx ../camlp4/quotation.cmx

48
camlp4/etc/Makefile
View File

@ -4,16 +4,13 @@ include ../config/Makefile
INCLUDES=-I ../camlp4 -I ../boot -I $(OTOP)/lex
OCAMLCFLAGS=-warn-error A $(INCLUDES)
# pa_list, pa_scheme dont work any longer because of locations OBJS=q_phony.cmo pa_o.cmo pa_op.cmo pa_oop.cmo pa_ru.cmo pa_format.cmo pa_olabl.cmo pa_sml.cmo pa_lisp.cmo pa_scheme.cmo pa_extfold.cmo pa_extfun.cmo pa_fstream.cmo pa_lefteval.cmo pa_ifdef.cmo pr_r.cmo pr_rp.cmo pr_o.cmo pr_op.cmo pr_scheme.cmo pr_schemep.cmo pr_extend.cmo pr_extfun.cmo pr_null.cmo pr_depend.cmo
OBJS=q_phony.cmo pa_o.cmo pa_op.cmo pa_oop.cmo pa_ru.cmo pa_format.cmo pa_olabl.cmo pa_sml.cmo pa_extfold.cmo pa_extfun.cmo pa_fstream.cmo pa_lefteval.cmo pa_ifdef.cmo pr_r.cmo pr_rp.cmo pr_o.cmo pr_op.cmo pr_scheme.cmo pr_schemep.cmo pr_extend.cmo pr_extfun.cmo pr_null.cmo pr_depend.cmo
OBJS=q_phony.cmo pa_o.cmo pa_op.cmo pa_oop.cmo pa_ru.cmo pa_extfold.cmo pa_extfun.cmo pa_fstream.cmo pa_ifdef.cmo pr_r.cmo pr_rp.cmo pr_o.cmo pr_op.cmo pr_extend.cmo pr_extfun.cmo pr_null.cmo pr_depend.cmo
OBJSX=$(OBJS:.cmo=.cmx)
INTF=pa_o.cmi
CAMLP4OM=pa_o.cmo pa_op.cmo ../meta/pr_dump.cmo
CAMLP4OMX=$(CAMLP4OM:.cmo=.cmx)
CAMLP4SCHM=pa_scheme.cmo ../meta/pr_dump.cmo
SHELL=/bin/sh
# camlp4schm is broken COUT=$(OBJS) camlp4o$(EXE) #camlp4sch$(EXE)
COUT=$(OBJS) camlp4o$(EXE)
COPT=$(OBJSX) camlp4o.opt
@ -26,32 +23,20 @@ pr_rp.cmo: parserify.cmo pr_rp_main.cmo
pr_op.cmo: parserify.cmo pr_op_main.cmo
$(OCAMLC) parserify.cmo pr_op_main.cmo -a -o $@
pr_schemep.cmo: parserify.cmo pr_schp_main.cmo
$(OCAMLC) parserify.cmo pr_schp_main.cmo -a -o $@
pr_rp.cmx: parserify.cmx pr_rp_main.cmx
$(OCAMLOPT) parserify.cmx pr_rp_main.cmx -a -o pr_rp.cmxa
mv pr_rp.cmxa pr_rp.cmx
mv pr_rp.a pr_rp.o
mv pr_rp.$(A) pr_rp.$(O)
pr_op.cmx: parserify.cmx pr_op_main.cmx
$(OCAMLOPT) parserify.cmx pr_op_main.cmx -a -o pr_op.cmxa
mv pr_op.cmxa pr_op.cmx
mv pr_op.a pr_op.o
pr_schemep.cmx: parserify.cmx pr_schp_main.cmx
$(OCAMLOPT) parserify.cmx pr_schp_main.cmx -a -o pr_schemep.cmxa
mv pr_schemep.cmxa pr_schemep.cmx
mv pr_schemep.a pr_schemep.o
mv pr_op.$(A) pr_op.$(O)
camlp4o$(EXE): ../camlp4/camlp4$(EXE) $(CAMLP4OM)
rm -f camlp4o$(EXE)
cd ../camlp4; $(MAKE) CAMLP4=../etc/camlp4o$(EXE) CAMLP4M="-I ../etc $(CAMLP4OM)"
camlp4sch$(EXE): ../camlp4/camlp4$(EXE) $(CAMLP4SCHM)
rm -f camlp4sch$(EXE)
cd ../camlp4; $(MAKE) CAMLP4=../etc/camlp4sch$(EXE) CAMLP4M="-I ../etc $(CAMLP4SCHM)"
camlp4o.opt: $(CAMLP4OMX)
rm -f camlp4o.opt
cd ../camlp4; $(MAKE) optp4 CAMLP4OPT=../etc/camlp4o.opt CAMLP4M="-I ../etc $(CAMLP4OMX)"
@ -59,18 +44,6 @@ camlp4o.opt: $(CAMLP4OMX)
mkcamlp4.sh: mkcamlp4.sh.tpl
sed -e "s!LIBDIR!$(LIBDIR)!g" mkcamlp4.sh.tpl > mkcamlp4.sh
pa_ocamllex.cma: pa_ocamllex.cmo
$(OCAMLC) -I $(OTOP)/lex cset.cmo syntax.cmo table.cmo lexgen.cmo compact.cmo pa_ocamllex.cmo -a -o pa_ocamllex.cma
bootstrap_scheme:
@$(MAKE) bootstrap_l L=scheme | grep -v directory
compare_scheme:
@$(MAKE) compare_l L=scheme | grep -v directory
bootstrap_lisp:
@$(MAKE) bootstrap_l L=lisp | grep -v directory
compare_lisp:
@$(MAKE) compare_l L=lisp | grep -v directory
bootstrap_l:
../boot/camlp4 ./pa_$Lr.cmo ./q_phony.cmo -I ../boot pa_extend.cmo ./pr_r.cmo ./pr_extend.cmo ./pr_rp.cmo pa_$L.ml > tmp
mv pa_$Lr.ml pa_$Lr.ml.old
@ -81,7 +54,7 @@ compare_l:
../boot/camlp4 ./pa_$Lr.cmo ./q_phony.cmo -I ../boot pa_extend.cmo ./pr_r.cmo ./pr_extend.cmo ./pr_rp.cmo pa_$L.ml | sed -e 's/^;; \(.*\)$$/(* \1 *)/' -e 's/^; \(.*\)$$/(* \1 *)/' -e 's|./pa_$Lr.cmo|pa_r.cmo pa_rp.cmo|' -e 's/$$Id.*\$$/File generated by pretty print; do not edit!/' | diff -c pa_$Lr.ml -
clean::
rm -f *.cm* *.pp[io] *.o *.bak .*.bak *.out *.opt
rm -f *.cm* *.pp[io] *.$(O) *.bak .*.bak *.out *.opt
rm -f mkcamlp4.sh camlp4o$(EXE) camlp4sch$(EXE)
depend:
@ -98,16 +71,17 @@ install:
-$(MKDIR) "$(LIBDIR)/camlp4" "$(BINDIR)"
cp $(OBJS) "$(LIBDIR)/camlp4/."
cp $(INTF) "$(LIBDIR)/camlp4/."
cp lib.sml "$(LIBDIR)/camlp4/."
# cp camlp4o$(EXE) camlp4sch$(EXE) "$(BINDIR)/."
cp camlp4o$(EXE) "$(BINDIR)/."
if test -f camlp4o.opt; then cp camlp4o.opt "$(BINDIR)/camlp4o.opt$(EXE)"; cp $(OBJSX) $(OBJSX:.cmx=.o) "$(LIBDIR)/camlp4/."; fi
if test -f camlp4o.opt; then \
cp camlp4o.opt "$(BINDIR)/camlp4o.opt$(EXE)"; \
cp $(OBJSX) "$(LIBDIR)/camlp4/."; \
for file in $(OBJSX); do \
cp "`echo $$file | sed -e 's/\.cmx$$/.$(O)/'`" "$(LIBDIR)/camlp4/."; \
done ; \
fi
cp mkcamlp4.sh "$(BINDIR)/mkcamlp4"
chmod a+x "$(BINDIR)/mkcamlp4"
pa_lisp.cmo: pa_lispr.cmo
pa_scheme.cmo: pa_schemer.cmo
pa_ocamllex.cmo: pa_o.cmo
pr_extend.cmo: pa_extfun.cmo
pr_o.cmo: pa_extfun.cmo
pr_op.cmo: pa_extfun.cmo

384
camlp4/etc/lib.sml
View File

@ -1,384 +0,0 @@
(* $Id$ *)
datatype 'a option = SOME of 'a | NONE
exception Fail of string
exception Domain
exception Subscript
type 'a vector = 'a array
structure OCaml =
struct
structure List = List
structure String = String
end
structure Time =
struct
datatype time = TIME of { sec : int, usec : int }
fun toString _ = failwith "not implemented Time.toString"
fun now _ = failwith "not implemented Time.now"
end
datatype cpu_timer =
CPUT of { gc : Time.time, sys : Time.time, usr : Time.time }
datatype real_timer =
RealT of Time.time
structure Char =
struct
val ord = Char.code
end
structure General =
struct
datatype order = LESS | EQUAL | GREATER
end
type order = General.order == LESS | EQUAL | GREATER
structure OS =
struct
exception SysErr
structure Path =
struct
fun dir s =
let val r = Filename.dirname s in
if r = "." then "" else r
end
val file = Filename.basename
fun ext s =
let fun loop i =
if i < 0 then NONE
else if String.get s i = #"." then
let val len = String.length s - i - 1 in
if len = 0 then NONE else SOME (String.sub s (i + 1) len)
end
else loop (i - 1)
in
loop (String.length s - 1)
end
fun splitDirFile s =
{dir = Filename.dirname s,
file = Filename.basename s}
fun joinDirFile x =
let val {dir,file} = x in Filename.concat dir file end
end
structure FileSys =
struct
datatype access_mode = A_READ | A_WRITE | A_EXEC
val chDir = Sys.chdir
fun isDir s =
(Unix.stat s) ocaml_record_access Unix.st_kind = Unix.S_DIR
handle Unix.Unix_error _ => raise SysErr
fun access (s, accs) =
let val st = Unix.stat s
val prm = st ocaml_record_access Unix.st_perm
val prm =
if st ocaml_record_access Unix.st_uid = Unix.getuid () then
lsr prm 6
else if st ocaml_record_access Unix.st_uid = Unix.getgid ()
then
lsr prm 3
else prm
val rf =
if List.mem A_READ accs then land prm 4 <> 0 else true
val wf =
if List.mem A_WRITE accs then land prm 2 <> 0 else true
val xf =
if List.mem A_EXEC accs then land prm 1 <> 0 else true
in
rf andalso wf andalso xf
end
handle Unix.Unix_error (_, f, _) =>
if f = "stat" then false else raise SysErr
end
structure Process =
struct
fun system s = (flush stdout; flush stderr; Sys.command s)
fun getEnv s = SOME (Sys.getenv s) handle Not_found => NONE
val success = 0
end
end
exception SysErr = OS.SysErr
structure IO =
struct
exception Io of {cause:exn, function:string, name:string}
end
structure TextIO =
struct
type instream = in_channel * char option option ref
type outstream = out_channel
type elem = char
type vector = string
fun openIn fname =
(open_in fname, ref NONE) handle exn =>
raise IO.Io {cause = exn, function = "openIn", name = fname}
val openOut = open_out
fun closeIn (ic, ahc) = (ahc := SOME NONE; close_in ic)
val closeOut = close_out
val stdIn = (stdin, ref NONE)
fun endOfStream (ic, _) = pos_in ic = in_channel_length ic
fun inputLine (ic, ahc) =
case !ahc of
NONE =>
(input_line ic ^ "\n" handle End_of_file => (ahc := SOME NONE; ""))
| SOME NONE => ""
| SOME (SOME c) =>
(ahc := NONE;
if c = #"\n" then "\n"
else
String.make 1 c ^ input_line ic ^ "\n" handle
End_of_file => (ahc := SOME NONE; ""))
fun input1 (ic, ahc) =
case !ahc of
NONE =>
(SOME (input_char ic) handle End_of_file => (ahc := SOME NONE; NONE))
| SOME NONE => NONE
| SOME x => (ahc := NONE; x)
fun inputN (ins, n) =
let fun loop n =
if n <= 0 then ""
else
case input1 ins of
SOME c => String.make 1 c ^ loop (n - 1)
| NONE => ""
in
loop n
end
fun output (oc, v) = output_string oc v
fun inputAll ic = failwith "not implemented TextIO.inputAll"
fun lookahead (ic, ahc) =
case !ahc of
NONE => let val r = SOME (input_char ic) in ahc := SOME r; r end
| SOME x => x
fun print s = (print_string s; flush stdout)
end
structure Timer =
struct
fun startRealTimer () = failwith "not implemented Timer.startRealTimer"
fun startCPUTimer () = failwith "not implemented Timer.startCPUTimer"
fun checkRealTimer _ = failwith "not implemented Timer.checkRealTimer"
fun checkCPUTimer _ = failwith "not implemented Timer.checkCPUTimer"
end
structure Date =
struct
datatype month =
Jan | Feb | Mar | Apr | May | Jun | Jul | Sep | Oct | Nov | Dec
datatype wday = Sun | Mon | Tue | Wed | Thu | Fri | Sat
datatype date =
DATE of
{day : int, hour : int, isDst : bool option, minute : int,
month : month, offset : int option, second : int, wday : wday,
yday : int, year : int}
fun fmt _ _ = failwith "not implemented Date.fmt"
fun fromTimeLocal _ = failwith "not implemented Date.fromTimeLocal"
end
structure Posix =
struct
structure ProcEnv =
struct
fun getenv s = SOME (Sys.getenv s) handle Not_found => NONE
end
end
structure SMLofNJ =
struct
fun exportML s = failwith ("not implemented exportML " ^ s)
end
fun null x = x = []
fun explode s =
let fun loop i =
if i = String.length s then []
else String.get s i :: loop (i + 1)
in
loop 0
end
val app = List.iter
fun implode [] = ""
| implode (c :: l) = String.make 1 c ^ implode l
fun ooo f g x = f (g x)
structure Array =
struct
fun array (len, v) = Array.create len v
fun sub _ = failwith "not implemented Array.sub"
fun update _ = failwith "not implemented Array.update"
(* for make the profiler work *)
val set = Array.set
val get = Array.get
end
structure Vector =
struct
fun tabulate _ = failwith "not implemented Vector.tabulate"
fun sub _ = failwith "not implemented Vector.sub"
end
structure Bool =
struct
val toString = string_of_bool
end
structure String =
struct
val size = String.length
fun substring (s, beg, len) =
String.sub s beg len handle Invalid_argument _ => raise Subscript
val concat = String.concat ""
fun sub (s, i) = String.get s i
val str = String.make 1
fun compare (s1, s2) =
if s1 < s2 then LESS
else if s1 > s2 then GREATER
else EQUAL
fun isPrefix s1 s2 =
let fun loop i1 i2 =
if i1 >= String.length s1 then true
else if i2 >= String.length s2 then false
else if String.get s1 i1 = String.get s2 i2 then loop (i1 + 1) (i2 + 1)
else false
in
loop 0 0
end
fun tokens p s =
let fun loop tok i =
if i >= String.length s then
if tok = "" then [] else [tok]
else if p (String.get s i) then
if tok <> "" then tok :: loop "" (i + 1)
else loop "" (i + 1)
else loop (tok ^ String.make 1 (String.get s i)) (i + 1)
in
loop "" 0
end
fun extract _ = failwith "not implemented String.extract"
end
structure Substring =
struct
type substring = string * int * int
fun string (s : substring) = String.substring s
fun all s : substring = (s, 0, String.size s)
fun splitl f ((s, beg, len) : substring) : substring * substring =
let fun loop di =
if di = len then ((s, beg, len), (s, 0, 0))
else if f (String.sub (s, beg + di)) then loop (di + 1)
else ((s, beg, di), (s, beg + di, len - di))
in
loop 0
end
fun getc (s, i, len) =
if len > 0 andalso i < String.size s then
SOME (String.sub (s, i), (s, i+1, len-1))
else NONE
fun slice _ = failwith "not implemented: Substring.slice"
fun isEmpty (s, beg, len) = len = 0
fun concat sl = String.concat (List.map string sl)
end
type substring = Substring.substring
structure StringCvt =
struct
datatype radix = BIN | OCT | DEC | HEX
type ('a, 'b) reader = 'b -> ('a * 'b) option
end
structure ListPair =
struct
fun zip (a1::l1, a2::l2) = (a1, a2) :: zip (l1, l2)
| zip _ = []
val unzip = List.split
fun all f (x1 :: l1, x2 :: l2) = f (x1, x2) andalso all f (l1, l2)
| all _ _ = true
fun map f (a1::l1, a2::l2) =
let val r = f (a1, a2) in r :: map f (l1, l2) end
| map _ _ = []
end
structure ListMergeSort =
struct
fun uniqueSort cmp l =
List.sort
(fn x => fn y =>
case cmp (x, y) of
LESS => ~1
| EQUAL => 0
| GREATER => 1)
l
end
structure List =
struct
exception Empty
fun hd [] = raise Empty
| hd (x :: l) = x
fun tl [] = raise Empty
| tl (x :: l) = l
fun foldr f a l =
let fun loop a [] = a
| loop a (x :: l) = loop (f (x, a)) l
in
loop a (List.rev l)
end
fun foldl f a l = List.fold_left (fn a => fn x => f (x, a)) a l
val concat = List.flatten
val exists = List.exists
val filter = List.filter
val length = List.length
val map = List.map
val rev = List.rev
val all = List.for_all
fun find f [] = NONE
| find f (x :: l) = if f x then SOME x else find f l
fun last s =
case List.rev s of
[] => raise Empty
| x :: _ => x
fun take _ = failwith "not implemented: List.take"
fun partition _ = failwith "not implemented: List.partition"
fun mapPartial f [] = []
| mapPartial f (x :: l) =
case f x of
NONE => mapPartial f l
| SOME y => y :: mapPartial f l
fun op @ l1 l2 = List.rev_append (List.rev l1) l2
end
structure Int =
struct
type int1 = int
type int = int1
val toString = string_of_int
fun fromString s = SOME (int_of_string s) handle Failure _ => NONE
fun min (x, y) = if x < y then x else y
fun max (x, y) = if x > y then x else y
fun scan radix getc src = failwith "not impl: Int.scan"
end
val foldr = List.foldr
val exists = List.exists
val size = String.size
val substring = String.substring
val concat = String.concat
val length = List.length
val op @ = List.op @
val hd = List.hd
val tl = List.tl
val map = List.map
val rev = List.rev
val use_hook = ref (fn (s : string) => failwith "no defined directive use")
fun use s = !use_hook s
fun isSome (SOME _) = true
| isSome NONE = false
fun valOf (SOME x) = x
| valOf NONE = failwith "valOf"
val print = TextIO.print

39
camlp4/etc/pa_format.ml
View File

@ -1,39 +0,0 @@
(* camlp4r pa_extend.cmo q_MLast.cmo *)
(* $Id$ *)
open Pcaml;
EXTEND
GLOBAL: expr;
expr: LEVEL "top"
[ [ n = box_type; d = SELF; "begin";
el = LIST0 [ e = box_expr; ";" -> e ]; "end" ->
let el = [<:expr< Format.$lid:"open_" ^ n$ $d$ >> :: el] in
let el = el @ [<:expr< Format.close_box () >>] in
<:expr< do { $list:el$ } >>
| "hbox"; "begin"; el = LIST0 [ e = box_expr; ";" -> e ]; "end" ->
let el = [<:expr< Format.open_hbox () >> :: el] in
let el = el @ [<:expr< Format.close_box () >>] in
<:expr< do { $list:el$ } >>
| "nobox"; "begin"; el = LIST0 [ e = box_expr; ";" -> e ]; "end" ->
match el with
[ [e] -> e
| _ -> <:expr< do { $list:el$ } >> ] ] ]
;
box_type:
[ [ n = "hovbox" -> n
| n = "hvbox" -> n
| n = "vbox" -> n
| n = "box" -> n ] ]
;
box_expr:
[ [ s = STRING -> <:expr< Format.print_string $str:s$ >>
| UIDENT "STRING"; e = expr -> <:expr< Format.print_string $e$ >>
| UIDENT "INT"; e = expr -> <:expr< Format.print_int $e$ >>
| "/-" -> <:expr< Format.print_space () >>
| "//" -> <:expr< Format.print_cut () >>
| "!/" -> <:expr< Format.force_newline () >>
| "?/" -> <:expr< Format.print_if_newline () >>
| e = expr -> e ] ]
;
END;

6
camlp4/etc/pa_ifdef.ml
View File

@ -3,6 +3,10 @@
(* This module is deprecated since version 3.07; use pa_macro.ml instead *)
value _ =
prerr_endline "Warning: pa_ifdef is deprecated since OCaml 3.07. Use pa_macro instead."
;
type item_or_def 'a =
[ SdStr of 'a | SdDef of string | SdUnd of string | SdNop ]
;
@ -11,7 +15,7 @@ value list_remove x l =
List.fold_right (fun e l -> if e = x then l else [e :: l]) l []
;
value defined = ref ["OCAML_307"; "OCAML_305"; "CAMLP4_300"; "NEWSEQ"];
value defined = ref ["OCAML_308"; "OCAML_307"; "OCAML_305"; "CAMLP4_300"; "NEWSEQ"];
value define x = defined.val := [x :: defined.val];
value undef x = defined.val := list_remove x defined.val;

239
camlp4/etc/pa_lefteval.ml
View File

@ -1,239 +0,0 @@
(* camlp4r q_MLast.cmo *)
(***********************************************************************)
(* *)
(* Camlp4 *)
(* *)
(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *)
(* *)
(* Copyright 2002 Institut National de Recherche en Informatique et *)
(* Automatique. Distributed only by permission. *)
(* *)
(***********************************************************************)
(* $Id$ *)
value not_impl name x =
let desc =
if Obj.is_block (Obj.repr x) then
"tag = " ^ string_of_int (Obj.tag (Obj.repr x))
else "int_val = " ^ string_of_int (Obj.magic x)
in
failwith ("pa_lefteval: not impl: " ^ name ^ "; " ^ desc ^ ">")
;
value rec expr_fa al =
fun
[ <:expr< $f$ $a$ >> -> expr_fa [a :: al] f
| f -> (f, al) ]
;
(* generating let..in before functions calls which evaluates
several (more than one) of their arguments *)
value no_side_effects_ht =
let ht = Hashtbl.create 73 in
do {
List.iter (fun s -> Hashtbl.add ht s True)
["<"; "="; "@"; "^"; "+"; "-"; "ref"];
ht
}
;
value no_side_effects =
fun
[ <:expr< $uid:_$ >> -> True
| <:expr< $uid:_$ . $uid:_$ >> -> True
| <:expr< $lid:s$ >> ->
try Hashtbl.find no_side_effects_ht s with [ Not_found -> False ]
| _ -> False ]
;
value rec may_side_effect =
fun
[ <:expr< $lid:_$ >> | <:expr< $uid:_$ >> | <:expr< $str:_$ >> |
<:expr< $chr:_$ >> | <:expr< $int:_$ >> | <:expr< $flo:_$ >> |
<:expr< $_$ . $_$ >> | <:expr< fun [ $list:_$ ] >> ->
False
| <:expr< ($list:el$) >> -> List.exists may_side_effect el
| <:expr< $_$ $_$ >> as e ->
let (f, el) = expr_fa [] e in
not (no_side_effects f) || List.exists may_side_effect el
| _ -> True ]
;
value rec may_be_side_effect_victim =
fun
[ <:expr< $lid:_$ . $_$ >> -> True
| <:expr< $uid:_$ . $e$ >> -> may_be_side_effect_victim e
| _ -> False ]
;
value rec may_depend_on_order el =
loop False False el where rec loop
side_effect_found side_effect_victim_found =
fun
[ [e :: el] ->
if may_side_effect e then
if side_effect_found || side_effect_victim_found then True
else loop True True el
else if may_be_side_effect_victim e then
if side_effect_found then True else loop False True el
else loop side_effect_found side_effect_victim_found el
| [] -> False ]
;
value gen_let_in loc expr el =
let (pel, el) =
loop 0 (List.rev el) where rec loop n =
fun
[ [e :: el] ->
if may_side_effect e || may_be_side_effect_victim e then
if n = 0 then
let (pel, el) = loop 1 el in
(pel, [expr e :: el])
else
let id = "xxx" ^ string_of_int n in
let (pel, el) = loop (n + 1) el in
([(<:patt< $lid:id$ >>, expr e) :: pel],
[<:expr< $lid:id$ >> :: el])
else
let (pel, el) = loop n el in
(pel, [expr e :: el])
| [] -> ([], []) ]
in
match List.rev el with
[ [e :: el] -> (pel, e, el)
| _ -> assert False ]
;
value left_eval_apply loc expr e1 e2 =
let (f, el) = expr_fa [] <:expr< $e1$ $e2$ >> in
if not (may_depend_on_order [f :: el]) then <:expr< $expr e1$ $expr e2$ >>
else
let (pel, e, el) = gen_let_in loc expr [f :: el] in
let e = List.fold_left (fun e e1 -> <:expr< $e$ $e1$ >>) e el in
List.fold_left (fun e (p1, e1) -> <:expr< let $p1$ = $e1$ in $e$ >>) e pel
;
value left_eval_tuple loc expr el =
if not (may_depend_on_order el) then <:expr< ($list:List.map expr el$) >>
else
let (pel, e, el) = gen_let_in loc expr el in
List.fold_left (fun e (p1, e1) -> <:expr< let $p1$ = $e1$ in $e$ >>)
<:expr< ($list:[e :: el]$) >> pel
;
value left_eval_record loc expr lel =
let el = List.map snd lel in
if not (may_depend_on_order el) then
let lel = List.map (fun (p, e) -> (p, expr e)) lel in
<:expr< { $list:lel$ } >>
else
let (pel, e, el) = gen_let_in loc expr el in
let e =
let lel = List.combine (List.map fst lel) [e :: el] in
<:expr< { $list:lel$ } >>
in
List.fold_left (fun e (p1, e1) -> <:expr< let $p1$ = $e1$ in $e$ >>) e pel
;
value left_eval_assign loc expr e1 e2 = <:expr< $e1$ := $expr e2$ >>;
(* scanning the input tree, calling "left_eval_*" functions if necessary *)
value map_option f =
fun
[ Some x -> Some (f x)
| None -> None ]
;
value class_infos f ci =
{MLast.ciLoc = ci.MLast.ciLoc; MLast.ciVir = ci.MLast.ciVir;
MLast.ciPrm = ci.MLast.ciPrm; MLast.ciNam = ci.MLast.ciNam;
MLast.ciExp = f ci.MLast.ciExp}
;
value rec expr x =
let loc = MLast.loc_of_expr x in
match x with
[ <:expr< fun [ $list:pwel$ ] >> ->
<:expr< fun [ $list:List.map match_assoc pwel$ ] >>
| <:expr< match $e$ with [ $list:pwel$ ] >> ->
<:expr< match $expr e$ with [ $list:List.map match_assoc pwel$ ] >>
| <:expr< try $e$ with [ $list:pwel$ ] >> ->
<:expr< try $expr e$ with [ $list:List.map match_assoc pwel$ ] >>
| <:expr< let $opt:rf$ $list:pel$ in $e$ >> ->
<:expr< let $opt:rf$ $list:List.map let_binding pel$ in $expr e$ >>
| <:expr< let module $s$ = $me$ in $e$ >> ->
<:expr< let module $s$ = $module_expr me$ in $expr e$ >>
| <:expr< if $e1$ then $e2$ else $e3$ >> ->
<:expr< if $expr e1$ then $expr e2$ else $expr e3$ >>
| <:expr< while $e$ do { $list:el$ } >> ->
<:expr< while $expr e$ do { $list:List.map expr el$ } >>
| <:expr< do { $list:el$ } >> -> <:expr< do { $list:List.map expr el$ } >>
| <:expr< $e$ # $s$ >> -> <:expr< $expr e$ # $s$ >>
| <:expr< ($e$ : $t$) >> -> <:expr< ($expr e$ : $t$) >>
| <:expr< $e1$ || $e2$ >> -> <:expr< $expr e1$ || $expr e2$ >>
| <:expr< $e1$ && $e2$ >> -> <:expr< $expr e1$ && $expr e2$ >>
| <:expr< $e1$ $e2$ >> -> left_eval_apply loc expr e1 e2
| <:expr< ($list:el$) >> -> left_eval_tuple loc expr el
| <:expr< { $list:lel$ } >> -> left_eval_record loc expr lel
| <:expr< $e1$ := $e2$ >> -> left_eval_assign loc expr e1 e2
| <:expr< $_$ . $_$ >> | <:expr< $uid:_$ >> | <:expr< $lid:_$ >> |
<:expr< $str:_$ >> | <:expr< $chr:_$ >> | <:expr< $int:_$ >> |
<:expr< $flo:_$ >> | <:expr< new $list:_$ >> ->
x
| x -> not_impl "expr" x ]
and let_binding (p, e) = (p, expr e)
and match_assoc (p, eo, e) = (p, map_option expr eo, expr e)
and module_expr x =
let loc = MLast.loc_of_module_expr x in
match x with
[ <:module_expr< functor ($s$ : $mt$) -> $me$ >> ->
<:module_expr< functor ($s$ : $mt$) -> $module_expr me$ >>
| <:module_expr< ($me$ : $mt$) >> ->
<:module_expr< ($module_expr me$ : $mt$) >>
| <:module_expr< struct $list:sil$ end >> ->
<:module_expr< struct $list:List.map str_item sil$ end >>
| <:module_expr< $_$ . $_$ >> | <:module_expr< $_$ $_$ >> |
<:module_expr< $uid:_$ >> ->
x ]
and str_item x =
let loc = MLast.loc_of_str_item x in
match x with
[ <:str_item< module $s$ = $me$ >> ->
<:str_item< module $s$ = $module_expr me$ >>
| <:str_item< value $opt:rf$ $list:pel$ >> ->
<:str_item< value $opt:rf$ $list:List.map let_binding pel$ >>
| <:str_item< declare $list:sil$ end >> ->
<:str_item< declare $list:List.map str_item sil$ end >>
| <:str_item< class $list:ce$ >> ->
<:str_item< class $list:List.map (class_infos class_expr) ce$ >>
| <:str_item< $exp:e$ >> -> <:str_item< $exp:expr e$ >>
| <:str_item< open $_$ >> | <:str_item< type $list:_$ >> |
<:str_item< exception $_$ of $list:_$ = $_$ >> |
<:str_item< module type $_$ = $_$ >> | <:str_item< # $_$ $opt:_$ >> ->
x
| x -> not_impl "str_item" x ]
and class_expr x =
let loc = MLast.loc_of_class_expr x in
match x with
[ <:class_expr< object $opt:p$ $list:csil$ end >> ->
<:class_expr< object $opt:p$ $list:List.map class_str_item csil$ end >>
| x -> not_impl "class_expr" x ]
and class_str_item x =
let loc = MLast.loc_of_class_str_item x in
match x with
[ <:class_str_item< value $opt:mf$ $s$ = $e$ >> ->
<:class_str_item< value $opt:mf$ $s$ = $expr e$ >>
| <:class_str_item< method $s$ = $e$ >> ->
<:class_str_item< method $s$ = $expr e$ >>
| x -> not_impl "class_str_item" x ]
;
value parse_implem = Pcaml.parse_implem.val;
value parse_implem_with_left_eval strm =
let (r, b) = parse_implem strm in
(List.map (fun (si, loc) -> (str_item si, loc)) r, b)
;
Pcaml.parse_implem.val := parse_implem_with_left_eval;

684
camlp4/etc/pa_lisp.ml
View File

@ -1,684 +0,0 @@
;; camlp4 ./pa_lispr.cmo pa_extend.cmo q_MLast.cmo pr_dump.cmo
;; $Id$
(open Pcaml)
(open Stdpp)
(type (choice 'a 'b) (sum (Left 'a) (Right 'b)))
;; Buffer
(module Buff
(struct
(value buff (ref (String.create 80)))
(value store (lambda (len x)
(if (>= len (String.length buff.val))
(:= buff.val
(^ buff.val
(String.create (String.length buff.val)))))
(:= ([] buff.val len) x)
(succ len)))
(value get (lambda len (String.sub buff.val 0 len)))))
;; Lexer
(value rec skip_to_eol
(parser
(((` (or '\n' '\r'))) ())
(((` _) s) (skip_to_eol s))))
(value no_ident (list '(' ')' ' ' '\t' '\n' '\r' ';'))
(value rec ident
(lambda len
(parser
(((` x (not (List.mem x no_ident))) s)
(ident (Buff.store len x) s))
(()
(Buff.get len)))))
(value rec
string (lambda len
(parser
(((` '"')) (Buff.get len))
(((` '\\') (` c) s)
(string (Buff.store (Buff.store len '\\') c) s))
(((` x) s) (string (Buff.store len x) s)))))
(value rec
number (lambda len
(parser
(((` (as (range '0' '9') c)) s)
(number (Buff.store len c) s))
(()
(, "INT" (Buff.get len))))))
(value char_or_quote_id
(lambda x
(parser
(((` ''')) (, "CHAR" (String.make 1 x)))
((s)
(let ((len (Buff.store (Buff.store 0 ''') x)))
(, "LIDENT" (ident len s)))))))
(value rec char
(lambda len
(parser
(((` ''')) len)
(((` x) s) (char (Buff.store len x) s)))))
(value quote
(parser
(((` '\\') (len (char (Buff.store 0 '\\')))) (, "CHAR" (Buff.get len)))
(((` x) s) (char_or_quote_id x s))))
(value rec
lexer
(lambda kwt
(parser bp
(((` (or ' ' '\t' '\n' '\r')) s) (lexer kwt s))
(((` ';') (a (semi kwt bp))) a)
(((` '(')) (, (, "" "(") (, bp (+ bp 1))))
(((` ')')) (, (, "" ")") (, bp (+ bp 1))))
(((` '"') (s (string 0))) ep (, (, "STRING" s) (, bp ep)))
(((` ''') (tok quote)) ep (, tok (, bp ep)))
(((` '<') (tok less)) ep (, tok (, bp ep)))
(((` (as (range '0' '9') c)) (n (number (Buff.store 0 c)))) ep
(, n (, bp ep)))
(((` x) (s (ident (Buff.store 0 x)))) ep
(let ((con (try (progn (: (Hashtbl.find kwt s) unit) "")
(Not_found
(match x
((range 'A' 'Z') "UIDENT")
((_) "LIDENT"))))))
(, (, con s) (, bp ep))))
(() (, (, "EOI" "") (, bp (+ bp 1))))))
semi
(lambda (kwt bp)
(parser
(((` ';') (_ skip_to_eol) s) (lexer kwt s))
(() ep (, (, "" ";") (, bp ep)))))
less
(parser
(((` ':') (lab (label 0)) (? (` '<') "'<' expected") (q (quotation 0)))
(, "QUOT" (^ lab (^ ":" q))))
(() (, "LIDENT" "<")))
label
(lambda len
(parser
(((` (as (or (range 'a' 'z') (range 'A' 'Z') '_') c)) s)
(label (Buff.store len c) s))
(() (Buff.get len))))
quotation
(lambda len
(parser
(((` '>') s) (quotation_greater len s))
(((` x) s) (quotation (Buff.store len x) s))
(() (failwith "quotation not terminated"))))
quotation_greater
(lambda len
(parser
(((` '>')) (Buff.get len))
(((a (quotation (Buff.store len '>')))) a))))
(value lexer_using
(lambda (kwt (, con prm))
(match con
((or "CHAR" "EOI" "INT" "LIDENT" "QUOT" "STRING" "UIDENT") ())
(("ANTIQUOT") ())
(("")
(try (Hashtbl.find kwt prm)
(Not_found (Hashtbl.add kwt prm ()))))
(_ (raise
(Token.Error
(^ "the constructor \""
(^ con "\" is not recognized by Plexer"))))))))
(value lexer_text
(lambda (, con prm)
(if (= con "") (^ "'" (^ prm "'"))
(if (= prm "") con
(^ con (^ " \"" (^ prm "\"")))))))
(value lexer_gmake
(lambda ()
(let ((kwt (Hashtbl.create 89)))
({}
(Token.tok_func (Token.lexer_func_of_parser (lexer kwt)))
(Token.tok_using (lexer_using kwt))
(Token.tok_removing (lambda))
(Token.tok_match Token.default_match)
(Token.tok_text lexer_text)
(Token.tok_comm None)))))
;; Building AST
(type sexpr (sum
(Sexpr MLast.loc (list sexpr))
(Satom MLast.loc atom string)
(Squot MLast.loc string string))
atom (sum (Alid) (Auid) (Aint) (Achar) (Astring)))
(value error_loc
(lambda (loc err)
(raise_with_loc loc (Stream.Error (^ err " expected")))))
(value error
(lambda (se err)
(let ((loc (match se
((or (Satom loc _ _) (Sexpr loc _) (Squot loc _ _))
loc))))
(error_loc loc err))))
(value expr_id
(lambda (loc s)
(match ([] s 0)
((range 'A' 'Z') <:expr< $uid:s$ >>)
(_ <:expr< $lid:s$ >>))))
(value patt_id
(lambda (loc s)
(match ([] s 0)
((range 'A' 'Z') <:patt< $uid:s$ >>)
(_ <:patt< $lid:s$ >>))))
(value ctyp_id
(lambda (loc s)
(match ([] s 0)
(''' (let ((s (String.sub s 1 (- (String.length s) 1))))
<:ctyp< '$s$ >>))
((range 'A' 'Z') <:ctyp< $uid:s$ >>)
(_ <:ctyp< $lid:s$ >>))))
(value strm_n "strm__")
(value peek_fun (lambda loc <:expr< Stream.peek >>))
(value junk_fun (lambda loc <:expr< Stream.junk >>))
(value rec
module_expr_se
(lambda_match
((Sexpr loc (list (Satom _ Alid "struct") :: sl))
(let ((mel (List.map str_item_se sl)))
<:module_expr< struct $list:mel$ end >>))
((Satom loc Auid s)
<:module_expr< $uid:s$ >>)
((se)
(error se "module expr")))
str_item_se
(lambda se
(match se
((or (Satom loc _ _) (Squot loc _ _))
(let ((e (expr_se se))) <:str_item< $exp:e$ >>))
((Sexpr loc (list (Satom _ Alid "module") (Satom _ Auid i) se))
(let ((mb (module_binding_se se)))
<:str_item< module $i$ = $mb$ >>))
((Sexpr loc (list (Satom _ Alid "open") (Satom _ Auid s)))
(let ((s (list s)))
<:str_item< open $s$ >>))
((Sexpr loc (list (Satom _ Alid "type") :: sel))
(let ((tdl (type_declaration_list_se sel)))
<:str_item< type $list:tdl$ >>))
((Sexpr loc (list (Satom _ Alid "value") :: sel))
(let* (((, r sel)
(match sel
((list (Satom _ Alid "rec") :: sel) (, True sel))
((_) (, False sel))))
(lbs (value_binding_se sel)))
<:str_item< value $opt:r$ $list:lbs$ >>))
((Sexpr loc _)
(let ((e (expr_se se)))
<:str_item< $exp:e$ >>))))
value_binding_se
(lambda_match
((list se1 se2 :: sel)
(list (, (ipatt_se se1) (expr_se se2)) :: (value_binding_se sel)))
((list) (list))
((list se :: _) (error se "value_binding")))
module_binding_se
(lambda se (module_expr_se se))
expr_se
(lambda_match
((Satom loc (or Alid Auid) s)
(expr_ident_se loc s))
((Satom loc Aint s)
<:expr< $int:s$ >>)
((Satom loc Achar s)
(<:expr< $chr:s$ >>))
((Satom loc Astring s)
<:expr< $str:s$ >>)
((Sexpr loc (list))
<:expr< () >>)
((Sexpr loc (list (Satom _ Alid "if") se se1))
(let* ((e (expr_se se))
(e1 (expr_se se1)))
<:expr< if $e$ then $e1$ else () >>))
((Sexpr loc (list (Satom _ Alid "if") se se1 se2))
(let* ((e (expr_se se))
(e1 (expr_se se1))
(e2 (expr_se se2)))
<:expr< if $e$ then $e1$ else $e2$ >>))
((Sexpr loc (list (Satom loc1 Alid "lambda"))) <:expr< fun [] >>)
((Sexpr loc (list (Satom loc1 Alid "lambda") sep :: sel))
(let ((e (progn_se loc1 sel)))
(match (ipatt_opt_se sep)
((Left p) <:expr< fun $p$ -> $e$ >>)
((Right (, se sel))
(List.fold_right
(lambda (se e)
(let ((p (ipatt_se se))) <:expr< fun $p$ -> $e$ >>))
(list se :: sel) e)))))
((Sexpr loc (list (Satom _ Alid "lambda_match") :: sel))
(let ((pel (List.map (match_case loc) sel)))
<:expr< fun [ $list:pel$ ] >>))
((Sexpr loc (list (Satom _ Alid "let") :: sel))
(let (((, r sel)
(match sel
((list (Satom _ Alid "rec") :: sel) (, True sel))
((_) (, False sel)))))
(match sel
((list (Sexpr _ sel1) :: sel2)
(let* ((lbs (List.map let_binding_se sel1))
(e (progn_se loc sel2)))
<:expr< let $opt:r$ $list:lbs$ in $e$ >>))
((list se :: _) (error se "let_binding"))
((_) (error_loc loc "let_binding")))))
((Sexpr loc (list (Satom _ Alid "let*") :: sel))
(match sel
((list (Sexpr _ sel1) :: sel2)
(List.fold_right
(lambda (se ek)
(let (((, p e) (let_binding_se se)))
<:expr< let $p$ = $e$ in $ek$ >>))
sel1 (progn_se loc sel2)))
((list se :: _) (error se "let_binding"))
((_) (error_loc loc "let_binding"))))
((Sexpr loc (list (Satom _ Alid "match") se :: sel))
(let* ((e (expr_se se))
(pel (List.map (match_case loc) sel)))
<:expr< match $e$ with [ $list:pel$ ] >>))
((Sexpr loc (list (Satom _ Alid "parser") :: sel))
(let ((e (match sel
((list (as (Satom _ _ _) se) :: sel)
(let* ((p (patt_se se))
(pc (parser_cases_se loc sel)))
<:expr< let $p$ = Stream.count $lid:strm_n$ in $pc$ >>))
(_ (parser_cases_se loc sel)))))
<:expr< fun ($lid:strm_n$ : Stream.t _) -> $e$ >>))
((Sexpr loc (list (Satom _ Alid "try") se :: sel))
(let* ((e (expr_se se))
(pel (List.map (match_case loc) sel)))
<:expr< try $e$ with [ $list:pel$ ] >>))
((Sexpr loc (list (Satom _ Alid "progn") :: sel))
(let ((el (List.map expr_se sel)))
<:expr< do { $list:el$ } >>))
((Sexpr loc (list (Satom _ Alid "while") se :: sel))
(let* ((e (expr_se se))
(el (List.map expr_se sel)))
<:expr< while $e$ do { $list:el$ } >>))
((Sexpr loc (list (Satom _ Alid ":=") se1 se2))
(let ((e2 (expr_se se2)))
(match (expr_se se1)
(<:expr< $uid:"()"$ $e1$ $i$ >> <:expr< $e1$.($i$) := $e2$ >>)
(e1 <:expr< $e1$ := $e2$ >>))))
((Sexpr loc (list (Satom _ Alid "[]") se1 se2))
(let* ((e1 (expr_se se1)) (e2 (expr_se se2))) <:expr< $e1$.[$e2$] >>))
((Sexpr loc (list (Satom _ Alid ",") :: sel))
(let ((el (List.map expr_se sel))) <:expr< ( $list:el$ ) >>))
((Sexpr loc (list (Satom _ Alid "{}") :: sel))
(let ((lel (List.map (label_expr_se loc) sel))) <:expr< { $list:lel$ } >>))
((Sexpr loc (list (Satom _ Alid ":") se1 se2))
(let* ((e (expr_se se1))
(t (ctyp_se se2)))
<:expr< ( $e$ : $t$ ) >>))
((Sexpr loc (list (Satom _ Alid "list") :: sel))
(let rec ((loop
(lambda_match
((list) <:expr< [] >>)
((list se1 (Satom _ Alid "::") se2)
(let* ((e (expr_se se1))
(el (expr_se se2)))
<:expr< [$e$ :: $el$] >>))
((list se :: sel)
(let* ((e (expr_se se))
(el (loop sel)))
<:expr< [$e$ :: $el$] >>)))))
(loop sel)))
((Sexpr loc (list se :: sel))
(List.fold_left
(lambda (e se) (let ((e1 (expr_se se))) <:expr< $e$ $e1$ >>))
(expr_se se) sel))
((Squot loc typ txt)
(Pcaml.handle_expr_quotation loc (, typ txt))))
progn_se
(lambda loc
(lambda_match
((list) <:expr< () >>)
((list se) (expr_se se))
((sel) (let ((el (List.map expr_se sel))) <:expr< do { $list:el$ } >>))))
let_binding_se
(lambda_match
((Sexpr loc (list se1 se2)) (, (ipatt_se se1) (expr_se se2)))
(se (error se "let_binding")))
match_case
(lambda loc
(lambda_match
((Sexpr _ (list se1 se2))
(, (patt_se se1) None (expr_se se2)))
((Sexpr _ (list se1 sew se2))
(, (patt_se se1) (Some (expr_se sew)) (expr_se se2)))
(se (error se "match_case"))))
label_expr_se
(lambda loc
(lambda_match
((Sexpr _ (list se1 se2)) (, (patt_se se1) (expr_se se2)))
(se (error se ("label_expr")))))
expr_ident_se
(lambda (loc s)
(if (= ([] s 0) '<')
<:expr< $lid:s$ >>
(let rec
((loop
(lambda (ibeg i)
(if (= i (String.length s))
(if (> i ibeg)
(expr_id loc (String.sub s ibeg (- i ibeg)))
(raise_with_loc (, (- (+ (fst loc) i) 1)
(+ (fst loc) i))
(Stream.Error "expr expected")))
(if (= ([] s i) '.')
(if (> i ibeg)
(let* ((e1 (expr_id
loc
(String.sub s ibeg (- i ibeg))))
(e2 (loop (+ i 1) (+ i 1))))
<:expr< $e1$ . $e2$ >>)
(raise_with_loc (, (- (+ (fst loc) i) 1)
(+ (+ (fst loc) i) 1))
(Stream.Error "expr expected")))
(loop ibeg (+ i 1)))))))
(loop 0 0))))
parser_cases_se
(lambda loc
(lambda_match
((list) <:expr< raise Stream.Failure >>)
((list (Sexpr loc (list (Sexpr _ spsel) :: act)) :: sel)
(let* ((ekont (lambda _ (parser_cases_se loc sel)))
(act (match act
((list se) (expr_se se))
((list sep se)
(let* ((p (patt_se sep))
(e (expr_se se)))
<:expr< let $p$ = Stream.count $lid:strm_n$ in $e$ >>))
(_ (error_loc loc "parser_case")))))
(stream_pattern_se loc act ekont spsel)))
((list se :: _)
(error se "parser_case"))))
stream_pattern_se
(lambda (loc act ekont)
(lambda_match
((list) act)
((list se :: sel)
(let* ((ckont (lambda err <:expr< raise (Stream.Error $err$) >>))
(skont (stream_pattern_se loc act ckont sel)))
(stream_pattern_component skont ekont <:expr< "" >> se)))))
stream_pattern_component
(lambda (skont ekont err)
(lambda_match
((Sexpr loc (list (Satom _ Alid "`") se :: wol))
(let* ((wo (match wol
((list se) (Some (expr_se se)))
((list) None)
(_ (error_loc loc "stream_pattern_component"))))
(e (peek_fun loc))
(p (patt_se se))
(j (junk_fun loc))
(k (ekont err)))
<:expr< match $e$ $lid:strm_n$ with
[ Some $p$ $when:wo$ -> do { $j$ $lid:strm_n$ ; $skont$ }
| _ -> $k$ ] >>))
((Sexpr loc (list se1 se2))
(let* ((p (patt_se se1))
(e (let ((e (expr_se se2)))
<:expr< try Some ($e$ $lid:strm_n$) with [ Stream.Failure -> None ] >>))
(k (ekont err)))
<:expr< match $e$ with [ Some $p$ -> $skont$ | _ -> $k$ ] >>))
((Sexpr loc (list (Satom _ Alid "?") se1 se2))
(stream_pattern_component skont ekont (expr_se se2) se1))
((Satom loc Alid s)
<:expr< let $lid:s$ = $lid:strm_n$ in $skont$ >>)
(se
(error se "stream_pattern_component"))))
patt_se
(lambda_match
((Satom loc Alid "_") <:patt< _ >>)
((Satom loc (or Alid Auid) s) (patt_ident_se loc s))
((Satom loc Aint s)
<:patt< $int:s$ >>)
((Satom loc Achar s)
(<:patt< $chr:s$ >>))
((Satom loc Astring s)
<:patt< $str:s$ >>)
((Sexpr loc (list (Satom _ Alid "or") se :: sel))
(List.fold_left
(lambda (p se) (let ((p1 (patt_se se))) <:patt< $p$ | $p1$ >>))
(patt_se se) sel))
((Sexpr loc (list (Satom _ Alid "range") se1 se2))
(let* ((p1 (patt_se se1))
(p2 (patt_se se2)))
<:patt< $p1$ .. $p2$ >>))
((Sexpr loc (list (Satom _ Alid ",") :: sel))
(let ((pl (List.map patt_se sel))) <:patt< ( $list:pl$ ) >>))
((Sexpr loc (list (Satom _ Alid "as") se1 se2))
(let* ((p1 (patt_se se1))
(p2 (patt_se se2)))
<:patt< ($p1$ as $p2$) >>))
((Sexpr loc (list (Satom _ Alid "list") :: sel))
(let rec ((loop
(lambda_match
((list) <:patt< [] >>)
((list se1 (Satom _ Alid "::") se2)
(let* ((p (patt_se se1))
(pl (patt_se se2)))
<:patt< [$p$ :: $pl$] >>))
((list se :: sel)
(let* ((p (patt_se se))
(pl (loop sel)))
<:patt< [$p$ :: $pl$] >>)))))
(loop sel)))
((Sexpr loc (list se :: sel))
(List.fold_left
(lambda (p se) (let ((p1 (patt_se se))) <:patt< $p$ $p1$ >>))
(patt_se se) sel))
((Sexpr loc (list)) <:patt< () >>)
((Squot loc typ txt) (Pcaml.handle_patt_quotation loc (, typ txt))))
patt_ident_se
(lambda (loc s)
(let rec
((loop
(lambda (ibeg i)
(if (= i (String.length s))
(if (> i ibeg)
(patt_id loc (String.sub s ibeg (- i ibeg)))
(raise_with_loc (, (- (+ (fst loc) i) 1)
(+ (fst loc) i))
(Stream.Error "patt expected")))
(if (= ([] s i) '.')
(if (> i ibeg)
(let* ((p1 (patt_id
loc
(String.sub s ibeg (- i ibeg))))
(p2 (loop (+ i 1) (+ i 1))))
<:patt< $p1$ . $p2$ >>)
(raise_with_loc (, (- (+ (fst loc) i) 1)
(+ (+ (fst loc) i) 1))
(Stream.Error "patt expected")))
(loop ibeg (+ i 1)))))))
(loop 0 0)))
ipatt_se
(lambda se
(match (ipatt_opt_se se)
((Left p) p)
((Right (, se _))
(error se "ipatt"))))
ipatt_opt_se
(lambda_match
((Satom loc Alid "_") (Left <:patt< _ >>))
((Satom loc Alid s) (Left <:patt< $lid:s$ >>))
((Sexpr loc (list (Satom _ Alid ",") :: sel))
(let ((pl (List.map ipatt_se sel))) (Left <:patt< ( $list:pl$ ) >>)))
((Sexpr loc (list)) (Left <:patt< () >>))
((Sexpr loc (list se :: sel)) (Right (, se sel)))
(se (error se "ipatt")))
type_declaration_list_se
(lambda_match
((list se1 se2 :: sel)
(let (((, n1 loc1 tpl)
(match se1
((Sexpr _ (list (Satom loc Alid n) :: sel))
(, n loc (List.map type_parameter_se sel)))
((Satom loc Alid n)
(, n loc (list)))
((se)
(error se "type declaration")))))
(list (, (, loc1 n1) tpl (ctyp_se se2) (list)) ::
(type_declaration_list_se sel))))
((list) (list))
((list se :: _) (error se "type_declaration")))
type_parameter_se
(lambda_match
((Satom _ Alid s) (&& (>= (String.length s) 2) (= ([] s 0) '''))
(, (String.sub s 1 (- (String.length s) 1)) (, False False)))
(se
(error se "type_parameter")))
ctyp_se
(lambda_match
((Sexpr loc (list (Satom _ Alid "sum") :: sel))
(let ((cdl (List.map constructor_declaration_se sel)))
<:ctyp< [ $list:cdl$ ] >>))
((Sexpr loc (list se :: sel))
(List.fold_left
(lambda (t se) (let ((t2 (ctyp_se se))) <:ctyp< $t$ $t2$ >>))
(ctyp_se se) sel))
((Satom loc (or Alid Auid) s)
(ctyp_ident_se loc s))
(se
(error se "ctyp")))
ctyp_ident_se
(lambda (loc s)
(let rec
((loop (lambda (ibeg i)
(if (= i (String.length s))
(if (> i ibeg)
(ctyp_id loc (String.sub s ibeg (- i ibeg)))
(raise_with_loc (, (- (+ (fst loc) i) 1)
(+ (fst loc) i))
(Stream.Error "ctyp expected")))
(if (= ([] s i) '.')
(if (> i ibeg)
(let* ((t1 (ctyp_id
loc (String.sub s ibeg (- i ibeg))))
(t2 (loop (+ i 1) (+ i 1))))
<:ctyp< $t1$ . $t2$ >>)
(raise_with_loc (, (- (+ (fst loc) i) 1)
(+ (+ (fst loc) i) 1))
(Stream.Error "ctyp expected")))
(loop ibeg (+ i 1)))))))
(loop 0 0)))
constructor_declaration_se
(lambda_match
((Sexpr loc (list (Satom _ Auid ci) :: sel))
(, loc ci (List.map ctyp_se sel)))
(se
(error se "constructor_declaration"))))
(value top_phrase_se
(lambda se
(match se
((or (Satom loc _ _) (Squot loc _ _)) (str_item_se se))
((Sexpr loc (list (Satom _ Alid s) :: sl))
(if (= ([] s 0) '#')
(let ((n (String.sub s 1 (- (String.length s) 1))))
(match sl
((list (Satom _ Astring s))
(MLast.StDir loc n (Some <:expr< $str:s$ >>)))
(_ (match ()))))
(str_item_se se)))
((Sexpr loc _) (str_item_se se)))))
;; Parser
(value phony_quot (ref False))
(Pcaml.add_option "-phony_quot" (Arg.Set phony_quot) "phony quotations")
(:= Pcaml.no_constructors_arity.val False)
(progn
(Grammar.Unsafe.gram_reinit gram (lexer_gmake ()))
(Grammar.Unsafe.clear_entry interf)
(Grammar.Unsafe.clear_entry implem)
(Grammar.Unsafe.clear_entry top_phrase)
(Grammar.Unsafe.clear_entry use_file)
(Grammar.Unsafe.clear_entry module_type)
(Grammar.Unsafe.clear_entry module_expr)
(Grammar.Unsafe.clear_entry sig_item)
(Grammar.Unsafe.clear_entry str_item)
(Grammar.Unsafe.clear_entry expr)
(Grammar.Unsafe.clear_entry patt)
(Grammar.Unsafe.clear_entry ctyp)
(Grammar.Unsafe.clear_entry let_binding)
(Grammar.Unsafe.clear_entry class_type)
(Grammar.Unsafe.clear_entry class_expr)
(Grammar.Unsafe.clear_entry class_sig_item)
(Grammar.Unsafe.clear_entry class_str_item))
(:= Pcaml.parse_interf.val (Grammar.Entry.parse interf))
(:= Pcaml.parse_implem.val (Grammar.Entry.parse implem))
(value sexpr (Grammar.Entry.create gram "sexpr"))
(value atom (Grammar.Entry.create gram "atom"))
EXTEND
implem :
[ [ st = LIST0 [ s = str_item -> (, s loc) ]; EOI -> (, st False) ] ]
;
top_phrase :
[ [ se = sexpr -> (Some (top_phrase_se se))
| EOI -> None ] ]
;
use_file :
[ [ l = LIST0 sexpr; EOI -> (, (List.map top_phrase_se l) False) ] ]
;
str_item :
[ [ se = sexpr -> (str_item_se se)
| e = expr -> <:str_item< $exp:e$ >> ] ]
;
expr :
[ "top"
[ se = sexpr -> (expr_se se) ] ]
;
patt :
[ [ se = sexpr -> (patt_se se) ] ]
;
sexpr :
[ [ "("; sl = LIST0 sexpr; ")" -> (Sexpr loc sl)
| a = atom -> (Satom loc Alid a)
| s = LIDENT -> (Satom loc Alid s)
| s = UIDENT -> (Satom loc Auid s)
| s = INT -> (Satom loc Aint s)
| s = CHAR -> (Satom loc Achar s)
| s = STRING -> (Satom loc Astring s)
| s = QUOT ->
(let* ((i (String.index s ':'))
(typ (String.sub s 0 i))
(txt (String.sub s (+ i 1) (- (- (String.length s) i) 1))))
(if phony_quot.val
(Satom loc Alid (^ "<:" (^ typ (^ "<" (^ txt ">>")))))
(Squot loc typ txt))) ] ]
;
atom :
[ [ "_" -> "_"
| "," -> ","
| "=" -> "="
| ":" -> ":"
| "." -> "." ] ]
;
END

679
camlp4/etc/pa_lispr.ml
View File

@ -1,679 +0,0 @@
(* camlp4 pa_r.cmo pa_rp.cmo pa_extend.cmo q_MLast.cmo pr_dump.cmo *)
(* File generated by pretty print; do not edit! *)
open Pcaml;
open Stdpp;
type choice 'a 'b =
[ Left of 'a
| Right of 'b ]
;
(* Buffer *)
module Buff =
struct
value buff = ref (String.create 80);
value store len x =
do {
if len >= String.length buff.val then
buff.val := buff.val ^ String.create (String.length buff.val)
else ();
buff.val.[len] := x;
succ len
}
;
value get len = String.sub buff.val 0 len;
end
;
(* Lexer *)
value rec skip_to_eol =
parser
[ [: `'\n' | '\r' :] -> ()
| [: `_; s :] -> skip_to_eol s ]
;
value no_ident = ['('; ')'; ' '; '\t'; '\n'; '\r'; ';'];
value rec ident len =
parser
[ [: `x when not (List.mem x no_ident); s :] -> ident (Buff.store len x) s
| [: :] -> Buff.get len ]
;
value rec string len =
parser
[ [: `'"' :] -> Buff.get len
| [: `'\\'; `c; s :] -> string (Buff.store (Buff.store len '\\') c) s
| [: `x; s :] -> string (Buff.store len x) s ]
;
value rec number len =
parser
[ [: `('0'..'9' as c); s :] -> number (Buff.store len c) s
| [: :] -> ("INT", Buff.get len) ]
;
value char_or_quote_id x =
parser
[ [: `''' :] -> ("CHAR", String.make 1 x)
| [: s :] ->
let len = Buff.store (Buff.store 0 ''') x in
("LIDENT", ident len s) ]
;
value rec char len =
parser
[ [: `''' :] -> len
| [: `x; s :] -> char (Buff.store len x) s ]
;
value quote =
parser
[ [: `'\\'; len = char (Buff.store 0 '\\') :] -> ("CHAR", Buff.get len)
| [: `x; s :] -> char_or_quote_id x s ]
;
value rec lexer kwt fname lnum bolpos =
let make_pos p =
{Lexing.pos_fname = fname.val; Lexing.pos_lnum = lnum.val;
Lexing.pos_bol = bolpos.val; Lexing.pos_cnum = p} in
let mkloc (bp, ep) = (make_pos bp, make_pos ep) in
parser bp
[ [: `' ' | '\t' | '\n' | '\r'; s :] -> lexer kwt fname lnum bolpos s
| [: `';'; a = semi kwt mkloc fname lnum bolpos bp :] -> a
| [: `'(' :] -> (("", "("), mkloc(bp, bp + 1))
| [: `')' :] -> (("", ")"), mkloc(bp, bp + 1))
| [: `'"'; s = string 0 :] ep -> (("STRING", s), mkloc(bp, ep))
| [: `'''; tok = quote :] ep -> (tok, mkloc(bp, ep))
| [: `'<'; tok = less :] ep -> (tok, mkloc(bp, ep))
| [: `('0'..'9' as c); n = number (Buff.store 0 c) :] ep -> (n, mkloc(bp, ep))
| [: `x; s = ident (Buff.store 0 x) :] ep ->
let con =
try do { (Hashtbl.find kwt s : unit); "" } with
[ Not_found ->
match x with
[ 'A'..'Z' -> "UIDENT"
| _ -> "LIDENT" ] ]
in
((con, s), mkloc(bp, ep))
| [: :] -> (("EOI", ""), mkloc(bp, bp + 1)) ]
and semi kwt mkloc fname lnum bolpos bp =
parser
[ [: `';'; _ = skip_to_eol; s :] -> lexer kwt fname lnum bolpos s
| [: :] ep -> (("", ";"), mkloc(bp, ep)) ]
and less =
parser
[ [: `':'; lab = label 0; `'<' ? "'<' expected"; q = quotation 0 :] ->
("QUOT", lab ^ ":" ^ q)
| [: :] -> ("LIDENT", "<") ]
and label len =
parser
[ [: `('a'..'z' | 'A'..'Z' | '_' as c); s :] -> label (Buff.store len c) s
| [: :] -> Buff.get len ]
and quotation len =
parser
[ [: `'>'; s :] -> quotation_greater len s
| [: `x; s :] -> quotation (Buff.store len x) s
| [: :] -> failwith "quotation not terminated" ]
and quotation_greater len =
parser
[ [: `'>' :] -> Buff.get len
| [: a = quotation (Buff.store len '>') :] -> a ]
;
value lexer_using kwt (con, prm) =
match con with
[ "CHAR" | "EOI" | "INT" | "LIDENT" | "QUOT" | "STRING" | "UIDENT" -> ()
| "ANTIQUOT" -> ()
| "" ->
try Hashtbl.find kwt prm with [ Not_found -> Hashtbl.add kwt prm () ]
| _ ->
raise
(Token.Error
("the constructor \"" ^ con ^ "\" is not recognized by Plexer")) ]
;
value lexer_text (con, prm) =
if con = "" then "'" ^ prm ^ "'"
else if prm = "" then con
else con ^ " \"" ^ prm ^ "\""
;
value lexer_gmake () =
let bolpos = ref 0 in
let lnum = ref 0 in
let fname = ref "" in
let kwt = Hashtbl.create 89 in
{Token.tok_func = Token.lexer_func_of_parser (lexer kwt fname lnum bolpos);
Token.tok_using = lexer_using kwt; Token.tok_removing = fun [];
Token.tok_match = Token.default_match; Token.tok_text = lexer_text;
Token.tok_comm = None}
;
(* Building AST *)
type sexpr =
[ Sexpr of MLast.loc and list sexpr
| Satom of MLast.loc and atom and string
| Squot of MLast.loc and string and string ]
and atom =
[ Alid
| Auid
| Aint
| Achar
| Astring ]
;
value error_loc loc err =
raise_with_loc loc (Stream.Error (err ^ " expected"))
;
value error se err =
let loc =
match se with [ Satom loc _ _ | Sexpr loc _ | Squot loc _ _ -> loc ]
in
error_loc loc err
;
value expr_id loc s =
match s.[0] with
[ 'A'..'Z' -> <:expr< $uid:s$ >>
| _ -> <:expr< $lid:s$ >> ]
;
value patt_id loc s =
match s.[0] with
[ 'A'..'Z' -> <:patt< $uid:s$ >>
| _ -> <:patt< $lid:s$ >> ]
;
value ctyp_id loc s =
match s.[0] with
[ ''' ->
let s = String.sub s 1 (String.length s - 1) in
<:ctyp< '$s$ >>
| 'A'..'Z' -> <:ctyp< $uid:s$ >>
| _ -> <:ctyp< $lid:s$ >> ]
;
value strm_n = "strm__";
value peek_fun loc = <:expr< Stream.peek >>;
value junk_fun loc = <:expr< Stream.junk >>;
value rec module_expr_se =
fun
[ Sexpr loc [Satom _ Alid "struct" :: sl] ->
let mel = List.map str_item_se sl in
<:module_expr< struct $list:mel$ end >>
| Satom loc Auid s -> <:module_expr< $uid:s$ >>
| se -> error se "module expr" ]
and str_item_se se =
match se with
[ Satom loc _ _ | Squot loc _ _ ->
let e = expr_se se in
<:str_item< $exp:e$ >>
| Sexpr loc [Satom _ Alid "module"; Satom _ Auid i; se] ->
let mb = module_binding_se se in
<:str_item< module $i$ = $mb$ >>
| Sexpr loc [Satom _ Alid "open"; Satom _ Auid s] ->
let s = [s] in
<:str_item< open $s$ >>
| Sexpr loc [Satom _ Alid "type" :: sel] ->
let tdl = type_declaration_list_se sel in
<:str_item< type $list:tdl$ >>
| Sexpr loc [Satom _ Alid "value" :: sel] ->
let (r, sel) =
match sel with
[ [Satom _ Alid "rec" :: sel] -> (True, sel)
| _ -> (False, sel) ]
in
let lbs = value_binding_se sel in
<:str_item< value $opt:r$ $list:lbs$ >>
| Sexpr loc _ ->
let e = expr_se se in
<:str_item< $exp:e$ >> ]
and value_binding_se =
fun
[ [se1; se2 :: sel] -> [(ipatt_se se1, expr_se se2) :: value_binding_se sel]
| [] -> []
| [se :: _] -> error se "value_binding" ]
and module_binding_se se = module_expr_se se
and expr_se =
fun
[ Satom loc (Alid | Auid) s -> expr_ident_se loc s
| Satom loc Aint s -> <:expr< $int:s$ >>
| Satom loc Achar s -> <:expr< $chr:s$ >>
| Satom loc Astring s -> <:expr< $str:s$ >>
| Sexpr loc [] -> <:expr< () >>
| Sexpr loc [Satom _ Alid "if"; se; se1] ->
let e = expr_se se in
let e1 = expr_se se1 in
<:expr< if $e$ then $e1$ else () >>
| Sexpr loc [Satom _ Alid "if"; se; se1; se2] ->
let e = expr_se se in
let e1 = expr_se se1 in
let e2 = expr_se se2 in
<:expr< if $e$ then $e1$ else $e2$ >>
| Sexpr loc [Satom loc1 Alid "lambda"] -> <:expr< fun [] >>
| Sexpr loc [Satom loc1 Alid "lambda"; sep :: sel] ->
let e = progn_se loc1 sel in
match ipatt_opt_se sep with
[ Left p -> <:expr< fun $p$ -> $e$ >>
| Right (se, sel) ->
List.fold_right
(fun se e ->
let p = ipatt_se se in
<:expr< fun $p$ -> $e$ >>)
[se :: sel] e ]
| Sexpr loc [Satom _ Alid "lambda_match" :: sel] ->
let pel = List.map (match_case loc) sel in
<:expr< fun [ $list:pel$ ] >>
| Sexpr loc [Satom _ Alid "let" :: sel] ->
let (r, sel) =
match sel with
[ [Satom _ Alid "rec" :: sel] -> (True, sel)
| _ -> (False, sel) ]
in
match sel with
[ [Sexpr _ sel1 :: sel2] ->
let lbs = List.map let_binding_se sel1 in
let e = progn_se loc sel2 in
<:expr< let $opt:r$ $list:lbs$ in $e$ >>
| [se :: _] -> error se "let_binding"
| _ -> error_loc loc "let_binding" ]
| Sexpr loc [Satom _ Alid "let*" :: sel] ->
match sel with
[ [Sexpr _ sel1 :: sel2] ->
List.fold_right
(fun se ek ->
let (p, e) = let_binding_se se in
<:expr< let $p$ = $e$ in $ek$ >>)
sel1 (progn_se loc sel2)
| [se :: _] -> error se "let_binding"
| _ -> error_loc loc "let_binding" ]
| Sexpr loc [Satom _ Alid "match"; se :: sel] ->
let e = expr_se se in
let pel = List.map (match_case loc) sel in
<:expr< match $e$ with [ $list:pel$ ] >>
| Sexpr loc [Satom _ Alid "parser" :: sel] ->
let e =
match sel with
[ [(Satom _ _ _ as se) :: sel] ->
let p = patt_se se in
let pc = parser_cases_se loc sel in
<:expr< let $p$ = Stream.count $lid:strm_n$ in $pc$ >>
| _ -> parser_cases_se loc sel ]
in
<:expr< fun ($lid:strm_n$ : Stream.t _) -> $e$ >>
| Sexpr loc [Satom _ Alid "try"; se :: sel] ->
let e = expr_se se in
let pel = List.map (match_case loc) sel in
<:expr< try $e$ with [ $list:pel$ ] >>
| Sexpr loc [Satom _ Alid "progn" :: sel] ->
let el = List.map expr_se sel in
<:expr< do { $list:el$ } >>
| Sexpr loc [Satom _ Alid "while"; se :: sel] ->
let e = expr_se se in
let el = List.map expr_se sel in
<:expr< while $e$ do { $list:el$ } >>
| Sexpr loc [Satom _ Alid ":="; se1; se2] ->
let e2 = expr_se se2 in
match expr_se se1 with
[ <:expr< $uid:"()"$ $e1$ $i$ >> -> <:expr< $e1$.($i$) := $e2$ >>
| e1 -> <:expr< $e1$ := $e2$ >> ]
| Sexpr loc [Satom _ Alid "[]"; se1; se2] ->
let e1 = expr_se se1 in
let e2 = expr_se se2 in
<:expr< $e1$.[$e2$] >>
| Sexpr loc [Satom _ Alid "," :: sel] ->
let el = List.map expr_se sel in
<:expr< ( $list:el$ ) >>
| Sexpr loc [Satom _ Alid "{}" :: sel] ->
let lel = List.map (label_expr_se loc) sel in
<:expr< { $list:lel$ } >>
| Sexpr loc [Satom _ Alid ":"; se1; se2] ->
let e = expr_se se1 in
let t = ctyp_se se2 in
<:expr< ( $e$ : $t$ ) >>
| Sexpr loc [Satom _ Alid "list" :: sel] ->
let rec loop =
fun
[ [] -> <:expr< [] >>
| [se1; Satom _ Alid "::"; se2] ->
let e = expr_se se1 in
let el = expr_se se2 in
<:expr< [$e$ :: $el$] >>
| [se :: sel] ->
let e = expr_se se in
let el = loop sel in
<:expr< [$e$ :: $el$] >> ]
in
loop sel
| Sexpr loc [se :: sel] ->
List.fold_left
(fun e se ->
let e1 = expr_se se in
<:expr< $e$ $e1$ >>)
(expr_se se) sel
| Squot loc typ txt -> Pcaml.handle_expr_quotation loc (typ, txt) ]
and progn_se loc =
fun
[ [] -> <:expr< () >>
| [se] -> expr_se se
| sel ->
let el = List.map expr_se sel in
<:expr< do { $list:el$ } >> ]
and let_binding_se =
fun
[ Sexpr loc [se1; se2] -> (ipatt_se se1, expr_se se2)
| se -> error se "let_binding" ]
and match_case loc =
fun
[ Sexpr _ [se1; se2] -> (patt_se se1, None, expr_se se2)
| Sexpr _ [se1; sew; se2] -> (patt_se se1, Some (expr_se sew), expr_se se2)
| se -> error se "match_case" ]
and label_expr_se loc =
fun
[ Sexpr _ [se1; se2] -> (patt_se se1, expr_se se2)
| se -> error se "label_expr" ]
and expr_ident_se loc s =
if s.[0] = '<' then <:expr< $lid:s$ >>
else
let rec loop ibeg i =
if i = String.length s then
if i > ibeg then expr_id loc (String.sub s ibeg (i - ibeg))
else
raise_with_loc
(Reloc.shift_pos "pa_lisp:expr_ident_se1" (i-1) (fst loc), Reloc.shift_pos "pa_lisp:expr_ident_se2" i (fst loc))
(Stream.Error "expr expected")
else if s.[i] = '.' then
if i > ibeg then
let e1 = expr_id loc (String.sub s ibeg (i - ibeg)) in
let e2 = loop (i + 1) (i + 1) in
<:expr< $e1$ . $e2$ >>
else
raise_with_loc
(Reloc.shift_pos "pa_lisp:expr_ident_se3" (i-1) (fst loc), Reloc.shift_pos "pa_lisp:expr_ident_se4" (i+1) (fst loc))
(Stream.Error "expr expected")
else loop ibeg (i + 1)
in
loop 0 0
and parser_cases_se loc =
fun
[ [] -> <:expr< raise Stream.Failure >>
| [Sexpr loc [Sexpr _ spsel :: act] :: sel] ->
let ekont _ = parser_cases_se loc sel in
let act =
match act with
[ [se] -> expr_se se
| [sep; se] ->
let p = patt_se sep in
let e = expr_se se in
<:expr< let $p$ = Stream.count $lid:strm_n$ in $e$ >>
| _ -> error_loc loc "parser_case" ]
in
stream_pattern_se loc act ekont spsel
| [se :: _] -> error se "parser_case" ]
and stream_pattern_se loc act ekont =
fun
[ [] -> act
| [se :: sel] ->
let ckont err = <:expr< raise (Stream.Error $err$) >> in
let skont = stream_pattern_se loc act ckont sel in
stream_pattern_component skont ekont <:expr< "" >> se ]
and stream_pattern_component skont ekont err =
fun
[ Sexpr loc [Satom _ Alid "`"; se :: wol] ->
let wo =
match wol with
[ [se] -> Some (expr_se se)
| [] -> None
| _ -> error_loc loc "stream_pattern_component" ]
in
let e = peek_fun loc in
let p = patt_se se in
let j = junk_fun loc in
let k = ekont err in
<:expr< match $e$ $lid:strm_n$ with
[ Some $p$ $when:wo$ -> do { $j$ $lid:strm_n$ ; $skont$ }
| _ -> $k$ ] >>
| Sexpr loc [se1; se2] ->
let p = patt_se se1 in
let e =
let e = expr_se se2 in
<:expr< try Some ($e$ $lid:strm_n$) with [ Stream.Failure -> None ] >>
in
let k = ekont err in
<:expr< match $e$ with [ Some $p$ -> $skont$ | _ -> $k$ ] >>
| Sexpr loc [Satom _ Alid "?"; se1; se2] ->
stream_pattern_component skont ekont (expr_se se2) se1
| Satom loc Alid s -> <:expr< let $lid:s$ = $lid:strm_n$ in $skont$ >>
| se -> error se "stream_pattern_component" ]
and patt_se =
fun
[ Satom loc Alid "_" -> <:patt< _ >>
| Satom loc (Alid | Auid) s -> patt_ident_se loc s
| Satom loc Aint s -> <:patt< $int:s$ >>
| Satom loc Achar s -> <:patt< $chr:s$ >>
| Satom loc Astring s -> <:patt< $str:s$ >>
| Sexpr loc [Satom _ Alid "or"; se :: sel] ->
List.fold_left
(fun p se ->
let p1 = patt_se se in
<:patt< $p$ | $p1$ >>)
(patt_se se) sel
| Sexpr loc [Satom _ Alid "range"; se1; se2] ->
let p1 = patt_se se1 in
let p2 = patt_se se2 in
<:patt< $p1$ .. $p2$ >>
| Sexpr loc [Satom _ Alid "," :: sel] ->
let pl = List.map patt_se sel in
<:patt< ( $list:pl$ ) >>
| Sexpr loc [Satom _ Alid "as"; se1; se2] ->
let p1 = patt_se se1 in
let p2 = patt_se se2 in
<:patt< ($p1$ as $p2$) >>
| Sexpr loc [Satom _ Alid "list" :: sel] ->
let rec loop =
fun
[ [] -> <:patt< [] >>
| [se1; Satom _ Alid "::"; se2] ->
let p = patt_se se1 in
let pl = patt_se se2 in
<:patt< [$p$ :: $pl$] >>
| [se :: sel] ->
let p = patt_se se in
let pl = loop sel in
<:patt< [$p$ :: $pl$] >> ]
in
loop sel
| Sexpr loc [se :: sel] ->
List.fold_left
(fun p se ->
let p1 = patt_se se in
<:patt< $p$ $p1$ >>)
(patt_se se) sel
| Sexpr loc [] -> <:patt< () >>
| Squot loc typ txt -> Pcaml.handle_patt_quotation loc (typ, txt) ]
and patt_ident_se loc s =
loop 0 0 where rec loop ibeg i =
if i = String.length s then
if i > ibeg then patt_id loc (String.sub s ibeg (i - ibeg))
else
raise_with_loc
(Reloc.shift_pos "" (i-1) (fst loc), Reloc.shift_pos "" i (fst loc))
(Stream.Error "patt expected")
else if s.[i] = '.' then
if i > ibeg then
let p1 = patt_id loc (String.sub s ibeg (i - ibeg)) in
let p2 = loop (i + 1) (i + 1) in
<:patt< $p1$ . $p2$ >>
else
raise_with_loc
(Reloc.shift_pos "" (i-1) (fst loc), Reloc.shift_pos "" (i+1) (fst loc))
(Stream.Error "patt expected")
else loop ibeg (i + 1)
and ipatt_se se =
match ipatt_opt_se se with
[ Left p -> p
| Right (se, _) -> error se "ipatt" ]
and ipatt_opt_se =
fun
[ Satom loc Alid "_" -> Left <:patt< _ >>
| Satom loc Alid s -> Left <:patt< $lid:s$ >>
| Sexpr loc [Satom _ Alid "," :: sel] ->
let pl = List.map ipatt_se sel in
Left <:patt< ( $list:pl$ ) >>
| Sexpr loc [] -> Left <:patt< () >>
| Sexpr loc [se :: sel] -> Right (se, sel)
| se -> error se "ipatt" ]
and type_declaration_list_se =
fun
[ [se1; se2 :: sel] ->
let (n1, loc1, tpl) =
match se1 with
[ Sexpr _ [Satom loc Alid n :: sel] ->
(n, loc, List.map type_parameter_se sel)
| Satom loc Alid n -> (n, loc, [])
| se -> error se "type declaration" ]
in
[((loc1, n1), tpl, ctyp_se se2, []) :: type_declaration_list_se sel]
| [] -> []
| [se :: _] -> error se "type_declaration" ]
and type_parameter_se =
fun
[ Satom _ Alid s when String.length s >= 2 && s.[0] = ''' ->
(String.sub s 1 (String.length s - 1), (False, False))
| se -> error se "type_parameter" ]
and ctyp_se =
fun
[ Sexpr loc [Satom _ Alid "sum" :: sel] ->
let cdl = List.map constructor_declaration_se sel in
<:ctyp< [ $list:cdl$ ] >>
| Sexpr loc [se :: sel] ->
List.fold_left
(fun t se ->
let t2 = ctyp_se se in
<:ctyp< $t$ $t2$ >>)
(ctyp_se se) sel
| Satom loc (Alid | Auid) s -> ctyp_ident_se loc s
| se -> error se "ctyp" ]
and ctyp_ident_se loc s =
loop 0 0 where rec loop ibeg i =
if i = String.length s then
if i > ibeg then ctyp_id loc (String.sub s ibeg (i - ibeg))
else
raise_with_loc
(Reloc.shift_pos "" (i-1) (fst loc), Reloc.shift_pos "" i (fst loc))
(Stream.Error "ctyp expected")
else if s.[i] = '.' then
if i > ibeg then
let t1 = ctyp_id loc (String.sub s ibeg (i - ibeg)) in
let t2 = loop (i + 1) (i + 1) in
<:ctyp< $t1$ . $t2$ >>
else
raise_with_loc
(Reloc.shift_pos "" (i-1) (fst loc), Reloc.shift_pos "" (i+1) (fst loc))
(Stream.Error "ctyp expected")
else loop ibeg (i + 1)
and constructor_declaration_se =
fun
[ Sexpr loc [Satom _ Auid ci :: sel] -> (loc, ci, List.map ctyp_se sel)
| se -> error se "constructor_declaration" ]
;
value top_phrase_se se =
match se with
[ Satom loc _ _ | Squot loc _ _ -> str_item_se se
| Sexpr loc [Satom _ Alid s :: sl] ->
if s.[0] = '#' then
let n = String.sub s 1 (String.length s - 1) in
match sl with
[ [Satom _ Astring s] -> MLast.StDir loc n (Some <:expr< $str:s$ >>)
| _ -> match () with [] ]
else str_item_se se
| Sexpr loc _ -> str_item_se se ]
;
(* Parser *)
value phony_quot = ref False;
Pcaml.add_option "-phony_quot" (Arg.Set phony_quot) "phony quotations";
Pcaml.no_constructors_arity.val := False;
do {
Grammar.Unsafe.gram_reinit gram (lexer_gmake ());
Grammar.Unsafe.clear_entry interf;
Grammar.Unsafe.clear_entry implem;
Grammar.Unsafe.clear_entry top_phrase;
Grammar.Unsafe.clear_entry use_file;
Grammar.Unsafe.clear_entry module_type;
Grammar.Unsafe.clear_entry module_expr;
Grammar.Unsafe.clear_entry sig_item;
Grammar.Unsafe.clear_entry str_item;
Grammar.Unsafe.clear_entry expr;
Grammar.Unsafe.clear_entry patt;
Grammar.Unsafe.clear_entry ctyp;
Grammar.Unsafe.clear_entry let_binding;
Grammar.Unsafe.clear_entry class_type;
Grammar.Unsafe.clear_entry class_expr;
Grammar.Unsafe.clear_entry class_sig_item;
Grammar.Unsafe.clear_entry class_str_item
};
Pcaml.parse_interf.val := Grammar.Entry.parse interf;
Pcaml.parse_implem.val := Grammar.Entry.parse implem;
value sexpr = Grammar.Entry.create gram "sexpr";
value atom = Grammar.Entry.create gram "atom";
EXTEND
implem:
[ [ st = LIST0 [ s = str_item -> (s, loc) ]; EOI -> (st, False) ] ]
;
top_phrase:
[ [ se = sexpr -> Some (top_phrase_se se)
| EOI -> None ] ]
;
use_file:
[ [ l = LIST0 sexpr; EOI -> (List.map top_phrase_se l, False) ] ]
;
str_item:
[ [ se = sexpr -> str_item_se se
| e = expr -> <:str_item< $exp:e$ >> ] ]
;
expr:
[ "top"
[ se = sexpr -> expr_se se ] ]
;
patt:
[ [ se = sexpr -> patt_se se ] ]
;
sexpr:
[ [ "("; sl = LIST0 sexpr; ")" -> Sexpr loc sl
| a = atom -> Satom loc Alid a
| s = LIDENT -> Satom loc Alid s
| s = UIDENT -> Satom loc Auid s
| s = INT -> Satom loc Aint s
| s = CHAR -> Satom loc Achar s
| s = STRING -> Satom loc Astring s
| s = QUOT ->
let i = String.index s ':' in
let typ = String.sub s 0 i in
let txt = String.sub s (i + 1) (String.length s - i - 1) in
if phony_quot.val then
Satom loc Alid ("<:" ^ typ ^ "<" ^ txt ^ ">>")
else Squot loc typ txt ] ]
;
atom:
[ [ "_" -> "_"
| "," -> ","
| "=" -> "="
| ":" -> ":"
| "." -> "." ] ]
;
END;

344
camlp4/etc/pa_ocamllex.ml
View File

@ -1,344 +0,0 @@
(* camlp4 ./pa_o.cmo q_MLast.cmo pa_extend.cmo pr_dump.cmo *)
(* $Id$ *)
(* Alain Frisch's contribution *)
open Syntax
open Lexgen
open Compact
(* Adapted from output.ml *)
(**************************)
(* Output the DFA tables and its entry points *)
(* To output an array of short ints, encoded as a string *)
let output_byte buf b =
Buffer.add_char buf '\\';
Buffer.add_char buf (Char.chr(48 + b / 100));
Buffer.add_char buf (Char.chr(48 + (b / 10) mod 10));
Buffer.add_char buf (Char.chr(48 + b mod 10))
let loc = (Lexing.dummy_pos,Lexing.dummy_pos)
let output_array v =
let b = Buffer.create (Array.length v * 3) in
for i = 0 to Array.length v - 1 do
output_byte b (v.(i) land 0xFF);
output_byte b ((v.(i) asr 8) land 0xFF);
if i land 7 = 7 then Buffer.add_string b "\\\n "
done;
let s = Buffer.contents b in
<:expr< $str:s$ >>
let output_byte_array v =
let b = Buffer.create (Array.length v * 2) in
for i = 0 to Array.length v - 1 do
output_byte b (v.(i) land 0xFF);
if i land 15 = 15 then Buffer.add_string b "\\\n "
done;
let s = Buffer.contents b in
<:expr< $str:s$ >>
(* Output the tables *)
let output_tables tbl =
<:str_item< value lex_tables = {
Lexing.lex_base = $output_array tbl.tbl_base$;
Lexing.lex_backtrk = $output_array tbl.tbl_backtrk$;
Lexing.lex_default = $output_array tbl.tbl_default$;
Lexing.lex_trans = $output_array tbl.tbl_trans$;
Lexing.lex_check = $output_array tbl.tbl_check$;
Lexing.lex_base_code = $output_array tbl.tbl_base_code$;
Lexing.lex_backtrk_code = $output_array tbl.tbl_backtrk_code$;
Lexing.lex_default_code = $output_array tbl.tbl_default_code$;
Lexing.lex_trans_code = $output_array tbl.tbl_trans_code$;
Lexing.lex_check_code = $output_array tbl.tbl_check_code$;
Lexing.lex_code = $output_byte_array tbl.tbl_code$
} >>
(* Output the entries *)
let rec make_alias n = function
| [] -> []
| h::t ->
(h, "__ocaml_lex_arg_" ^ (string_of_int n)) :: (make_alias (succ n) t)
let abstraction =
List.fold_right (fun (p,a) e -> <:expr< fun ($p$ as $lid:a$) -> $e$ >>)
let application =
List.fold_left (fun f (_,a) -> <:expr< $f$ $lid:a$ >>)
let int i = <:expr< $int:string_of_int i$ >>
let output_memory_actions acts =
let aux = function
| Copy (tgt, src) ->
<:expr< lexbuf.Lexing.lex_mem.($int tgt$) :=
lexbuf.Lexing.lex_mem.($int src$) >>
| Set tgt ->
<:expr< lexbuf.Lexing.lex_mem.($int tgt$) :=
lexbuf.Lexing.lex_curr_pos >>
in
<:expr< do { $list:List.map aux acts$ } >>
let output_base_mem = function
| Mem i -> <:expr< lexbuf.Lexing.lex_mem.($int i$) >>
| Start -> <:expr< lexbuf.Lexing.lex_start_pos >>
| End -> <:expr< lexbuf.Lexing.lex_curr_pos >>
let output_tag_access = function
| Sum (a,0) -> output_base_mem a
| Sum (a,i) -> <:expr< $output_base_mem a$ + $int i$ >>
let rec output_env e = function
| [] -> e
| (x, Ident_string (o,nstart,nend)) :: rem ->
<:expr<
let $lid:x$ =
Lexing.$lid:if o then "sub_lexeme_opt" else "sub_lexeme"$
lexbuf $output_tag_access nstart$ $output_tag_access nend$
in $output_env e rem$
>>
| (x, Ident_char (o,nstart)) :: rem ->
<:expr<
let $lid:x$ =
Lexing.$lid: if o then "sub_lexeme_char_opt" else "sub_lexeme_char"$
lexbuf $output_tag_access nstart$
in $output_env e rem$
>>
let output_entry e =
let init_num, init_moves = e.auto_initial_state in
let args = make_alias 0 (e.auto_args @ [ <:patt< lexbuf >> ]) in
let f = "__ocaml_lex_rec_" ^ e.auto_name ^ "_rec" in
let call_f = application <:expr< $lid:f$ >> args in
let body_wrapper =
<:expr<
do {
lexbuf.Lexing.lex_mem := Array.create $int e.auto_mem_size$ (-1) ;
$output_memory_actions init_moves$;
$call_f$ $int init_num$
} >> in
let cases =
List.map
(fun (num, env, (loc,e)) ->
<:patt< $int:string_of_int num$ >>,
None,
output_env <:expr< $e$ >> env
(* Note: the <:expr<...>> above is there to set the location *)
) e.auto_actions @
[ <:patt< __ocaml_lex_n >>,
None,
<:expr< do
{ lexbuf.Lexing.refill_buff lexbuf; $call_f$ __ocaml_lex_n }>> ]
in
let engine =
if e.auto_mem_size = 0
then <:expr< Lexing.engine >>
else <:expr< Lexing.new_engine >> in
let body =
<:expr< fun state ->
match $engine$ lex_tables state lexbuf with [ $list:cases$ ] >> in
[
<:patt< $lid:e.auto_name$ >>, (abstraction args body_wrapper);
<:patt< $lid:f$ >>, (abstraction args body)
]
(* Main output function *)
exception Table_overflow
let output_lexdef tables entry_points =
Printf.eprintf
"pa_ocamllex: lexer found; %d states, %d transitions, table size %d bytes\n"
(Array.length tables.tbl_base)
(Array.length tables.tbl_trans)
(2 * (Array.length tables.tbl_base + Array.length tables.tbl_backtrk +
Array.length tables.tbl_default + Array.length tables.tbl_trans +
Array.length tables.tbl_check));
let size_groups =
(2 * (Array.length tables.tbl_base_code +
Array.length tables.tbl_backtrk_code +
Array.length tables.tbl_default_code +
Array.length tables.tbl_trans_code +
Array.length tables.tbl_check_code) +
Array.length tables.tbl_code) in
if size_groups > 0 then
Printf.eprintf "pa_ocamllex: %d additional bytes used for bindings\n"
size_groups ;
flush stderr;
if Array.length tables.tbl_trans > 0x8000 then raise Table_overflow;
let entries = List.map output_entry entry_points in
[output_tables tables; <:str_item< value rec $list:List.flatten entries$ >> ]
(* Adapted from parser.mly and main.ml *)
(***************************************)
(* Auxiliaries for the parser. *)
let char s = Char.code (Token.eval_char s)
let named_regexps =
(Hashtbl.create 13 : (string, regular_expression) Hashtbl.t)
let regexp_for_string s =
let rec re_string n =
if n >= String.length s then Epsilon
else if succ n = String.length s then
Characters (Cset.singleton (Char.code s.[n]))
else
Sequence
(Characters(Cset.singleton (Char.code s.[n])),
re_string (succ n))
in re_string 0
let char_class c1 c2 = Cset.interval c1 c2
let all_chars = Cset.all_chars
let rec remove_as = function
| Bind (e,_) -> remove_as e
| Epsilon|Eof|Characters _ as e -> e
| Sequence (e1, e2) -> Sequence (remove_as e1, remove_as e2)
| Alternative (e1, e2) -> Alternative (remove_as e1, remove_as e2)
| Repetition e -> Repetition (remove_as e)
let () =
Hashtbl.add named_regexps "eof" (Characters Cset.eof)
(* The parser *)
let let_regexp = Grammar.Entry.create Pcaml.gram "pa_ocamllex let"
let header = Grammar.Entry.create Pcaml.gram "pa_ocamllex header"
let lexer_def = Grammar.Entry.create Pcaml.gram "pa_ocaml lexerdef"
EXTEND
GLOBAL: Pcaml.str_item let_regexp header lexer_def;
let_regexp: [
[ x = LIDENT; "="; r = regexp ->
if Hashtbl.mem named_regexps x then
Printf.eprintf
"pa_ocamllex (warning): multiple definition of named regexp '%s'\n"
x;
Hashtbl.add named_regexps x r;
]
];
lexer_def: [
[ def = LIST0 definition SEP "and" ->
(try
let (entries, transitions) = make_dfa def in
let tables = compact_tables transitions in
let output = output_lexdef tables entries in
<:str_item< declare $list: output$ end >>
with
|Table_overflow ->
failwith "Transition table overflow in lexer, automaton is too big"
| Lexgen.Memory_overflow ->
failwith "Position memory overflow in lexer, too many as variables")
]
];
Pcaml.str_item: [
[ "pa_ocamllex"; LIDENT "rule"; d = lexer_def -> d
| "pa_ocamllex"; "let"; let_regexp ->
<:str_item< declare $list: []$ end >>
]
];
definition: [
[ x=LIDENT; pl = LIST0 Pcaml.patt LEVEL "simple"; "=";
short=[ LIDENT "parse" -> false | LIDENT "shortest" -> true ];
OPT "|"; l = LIST0 [ r=regexp; a=action -> (r,a) ] SEP "|" ->
{ name=x ; shortest=short ; args=pl ; clauses = l } ]
];
action: [
[ "{"; e = OPT Pcaml.expr; "}" ->
let e = match e with
| Some e -> e
| None -> <:expr< () >>
in
(loc,e)
]
];
header: [
[ "{"; e = LIST0 [ si = Pcaml.str_item; OPT ";;" -> si ]; "}" ->
[<:str_item< declare $list:e$ end>>, loc] ]
| [ -> [] ]
];
regexp: [
[ r = regexp; "as"; i = LIDENT -> Bind (r,i) ]
| [ r1 = regexp; "|"; r2 = regexp -> Alternative(r1,r2) ]
| [ r1 = regexp; r2 = regexp -> Sequence(r1,r2) ]
| [ r = regexp; "*" -> Repetition r
| r = regexp; "+" -> Sequence(Repetition (remove_as r), r)
| r = regexp; "?" -> Alternative(Epsilon, r)
| "("; r = regexp; ")" -> r
| "_" -> Characters all_chars
| c = CHAR -> Characters (Cset.singleton (char c))
| s = STRING -> regexp_for_string (Token.eval_string loc s)
| "["; cc = ch_class; "]" -> Characters cc
| x = LIDENT ->
try Hashtbl.find named_regexps x
with Not_found ->
failwith
("pa_ocamllex (error): reference to unbound regexp name `"^x^"'")
]
];
ch_class: [
[ "^"; cc = ch_class -> Cset.complement cc]
| [ c1 = CHAR; "-"; c2 = CHAR -> Cset.interval (char c1) (char c2)
| c = CHAR -> Cset.singleton (char c)
| cc1 = ch_class; cc2 = ch_class -> Cset.union cc1 cc2
]
];
END
(* We have to be careful about "rule"; in standalone mode,
it is used as a keyword (otherwise, there is a conflict
with named regexp); in normal mode, it is used as LIDENT
(we do not want to reserve such an useful identifier).
Plexer does not like identifiers used as keyword _and_
as LIDENT ...
*)
let standalone =
let already = ref false in
fun () ->
if not (!already) then
begin
already := true;
Printf.eprintf "pa_ocamllex: stand-alone mode\n";
DELETE_RULE Pcaml.str_item: "pa_ocamllex"; LIDENT "rule";lexer_def END;
DELETE_RULE Pcaml.str_item: "pa_ocamllex"; "let"; let_regexp END;
let ocamllex = Grammar.Entry.create Pcaml.gram "pa_ocamllex" in
EXTEND GLOBAL: ocamllex let_regexp header lexer_def;
ocamllex: [
[ h = header;
l = [LIST0 ["let"; let_regexp]; "rule"; d = lexer_def -> (d,loc)];
t = header; EOI -> h @ (l :: t) ,false
]
];
END;
Pcaml.parse_implem := Grammar.Entry.parse ocamllex
end
let () =
Pcaml.add_option "-ocamllex" (Arg.Unit standalone)
"Activate (standalone) ocamllex emulation mode."

2019
camlp4/etc/pa_olabl.ml
View File

File diff suppressed because it is too large Load Diff

1002
camlp4/etc/pa_scheme.ml
View File

File diff suppressed because it is too large Load Diff

1070
camlp4/etc/pa_schemer.ml
View File

File diff suppressed because it is too large Load Diff

949
camlp4/etc/pa_sml.ml
View File

@ -1,949 +0,0 @@
(* camlp4r pa_extend.cmo q_MLast.cmo *)
(***********************************************************************)
(* *)
(* Camlp4 *)
(* *)
(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *)
(* *)
(* Copyright 2002 Institut National de Recherche en Informatique et *)
(* Automatique. Distributed only by permission. *)
(* *)
(***********************************************************************)
(* $Id$ *)
open Stdpp;
open Pcaml;
value ocaml_records = ref False;
Pcaml.no_constructors_arity.val := True;
value lexer = Plexer.gmake ();
do {
Grammar.Unsafe.gram_reinit gram lexer;
Grammar.Unsafe.clear_entry interf;
Grammar.Unsafe.clear_entry implem;
Grammar.Unsafe.clear_entry top_phrase;
Grammar.Unsafe.clear_entry use_file;
Grammar.Unsafe.clear_entry module_type;
Grammar.Unsafe.clear_entry module_expr;
Grammar.Unsafe.clear_entry sig_item;
Grammar.Unsafe.clear_entry str_item;
Grammar.Unsafe.clear_entry expr;
Grammar.Unsafe.clear_entry patt;
Grammar.Unsafe.clear_entry ctyp;
Grammar.Unsafe.clear_entry let_binding;
};
Pcaml.parse_interf.val := Grammar.Entry.parse interf;
Pcaml.parse_implem.val := Grammar.Entry.parse implem;
value not_impl loc s =
raise_with_loc loc (Stream.Error ("not implemented feature [" ^ s ^ "]"))
;
type altern 'a 'b = [ Left of 'a | Right of 'b ];
value get_seq =
fun
[ <:expr< do { $list:el$ } >> -> el
| e -> [e] ]
;
value choose_tvar tpl =
let rec find_alpha v =
let s = String.make 1 v in
if List.mem_assoc s tpl then
if v = 'z' then None else find_alpha (Char.chr (Char.code v + 1))
else Some (String.make 1 v)
in
let rec make_n n =
let v = "a" ^ string_of_int n in
if List.mem_assoc v tpl then make_n (succ n) else v
in
match find_alpha 'a' with
[ Some x -> x
| None -> make_n 1 ]
;
value mklistexp loc last =
loop True where rec loop top =
fun
[ [] ->
match last with
[ Some e -> e
| None -> <:expr< [] >> ]
| [e1 :: el] ->
let loc = if top then loc else (fst (MLast.loc_of_expr e1), snd loc) in
<:expr< [$e1$ :: $loop False el$] >> ]
;
value mklistpat loc last =
loop True where rec loop top =
fun
[ [] ->
match last with
[ Some p -> p
| None -> <:patt< [] >> ]
| [p1 :: pl] ->
let loc = if top then loc else (fst (MLast.loc_of_patt p1), snd loc) in
<:patt< [$p1$ :: $loop False pl$] >> ]
;
value expr_of_patt p =
let loc = MLast.loc_of_patt p in
match p with
[ <:patt< $lid:x$ >> -> <:expr< $lid:x$ >>
| _ -> Stdpp.raise_with_loc loc (Stream.Error "identifier expected") ]
;
value apply_bind loc e bl =
let rec loop e =
fun
[ [] -> e
| [<:str_item< value $p1$ = $e1$ >> :: list] ->
loop_let e [(p1, e1)] list
| [<:str_item< value rec $p1$ = $e1$ >> :: list] ->
loop_letrec e [(p1, e1)] list
| [<:str_item< module $s$ = $me$ >> :: list] ->
let e = <:expr< let module $s$ = $me$ in $e$ >> in
loop e list
| [si :: list] ->
raise Exit ]
and loop_let e pel =
fun
[ [<:str_item< value $p1$ = $e1$ >> :: list] ->
loop_let e [(p1, e1) :: pel] list
| list ->
let e = <:expr< let $list:pel$ in $e$ >> in
loop e list ]
and loop_letrec e pel =
fun
[ [<:str_item< value rec $p1$ = $e1$ >> :: list] ->
loop_letrec e [(p1, e1) :: pel] list
| list ->
let e = <:expr< let rec $list:pel$ in $e$ >> in
loop e list ]
in
loop e (List.rev bl)
;
value make_local loc sl1 sl2 =
try
let pl =
List.map
(fun
[ <:str_item< value $opt:_$ $p$ = $_$ >> -> p
| _ -> raise Exit ])
sl2
in
let e1 =
match List.map expr_of_patt pl with
[ [e] -> e
| el -> <:expr< ($list:el$) >> ]
in
let p1 =
match pl with
[ [p] -> p
| pl -> <:patt< ($list:pl$) >> ]
in
let e = apply_bind loc e1 sl2 in
let e = apply_bind loc e sl1 in
<:str_item< value $p1$ = $e$ >>
with
[ Exit ->
do {
Printf.eprintf "\
*** Warning: a 'local' statement will be defined global because of bindings
which cannot be defined as first class values (modules, exceptions, ...)\n";
flush stderr;
<:str_item< declare $list:sl1 @ sl2$ end >>
} ]
;
value str_declare loc =
fun
[ [d] -> d
| dl -> <:str_item< declare $list:dl$ end >> ]
;
value sig_declare loc =
fun
[ [d] -> d
| dl -> <:sig_item< declare $list:dl$ end >> ]
;
value extract_label_types loc tn tal cdol =
let (cdl, aux) =
List.fold_right
(fun (loc, c, tl, aux_opt) (cdl, aux) ->
match aux_opt with
[ Some anon_record_type ->
let new_tn = tn ^ "_" ^ c in
let loc = MLast.loc_of_ctyp anon_record_type in
let aux_def = ((loc, new_tn), [], anon_record_type, []) in
let tl = [<:ctyp< $lid:new_tn$ >>] in
([(loc, c, tl) :: cdl], [aux_def :: aux])
| None -> ([(loc, c, tl) :: cdl], aux) ])
cdol ([], [])
in
[((loc, tn), tal, <:ctyp< [ $list:cdl$ ] >>, []) :: aux]
;
value function_of_clause_list loc xl =
let (fname, fname_loc, nbpat, l) =
List.fold_left
(fun (fname, fname_loc, nbpat, l) ((x1, loc), x2, x3, x4) ->
let (fname, fname_loc, nbpat) =
if fname = "" then (x1, loc, List.length x2)
else if x1 <> fname then
raise_with_loc loc
(Stream.Error ("'" ^ fname ^ "' expected"))
else if List.length x2 <> nbpat then
raise_with_loc loc
(Stream.Error "bad number of patterns in that clause")
else (fname, fname_loc, nbpat)
in
let x4 =
match x3 with
[ Some t -> <:expr< ($x4$ : $t$) >>
| _ -> x4 ]
in
let l = [(x2, x4) :: l] in
(fname, fname_loc, nbpat, l))
("", loc, 0, []) xl
in
let l = List.rev l in
let e =
match l with
[ [(pl, e)] ->
List.fold_right (fun p e -> <:expr< fun $p$ -> $e$ >>) pl e
| _ ->
if nbpat = 1 then
let pwel =
List.map
(fun (pl, e) -> (<:patt< $List.hd pl$ >>, None, e)) l
in
<:expr< fun [ $list:pwel$ ] >>
else
let sl =
loop 0 where rec loop n =
if n = nbpat then []
else ["a" ^ string_of_int (n + 1) :: loop (n + 1)]
in
let e =
let el = List.map (fun s -> <:expr< $lid:s$ >>) sl in
let pwel =
List.map
(fun (pl, e) -> (<:patt< ($list:pl$) >>, None, e)) l
in
<:expr< match ($list:el$) with [ $list:pwel$ ] >>
in
List.fold_right (fun s e -> <:expr< fun $lid:s$ -> $e$ >>) sl e ]
in
(let loc = fname_loc in <:patt< $lid:fname$ >>, e)
;
value record_expr loc x1 =
if ocaml_records.val then <:expr< { $list:x1$ } >>
else
let list1 =
List.map
(fun (l, v) ->
let id =
match l with
[ <:patt< $lid:l$ >> -> l
| _ -> "" ]
in
let loc = MLast.loc_of_expr v in
<:class_str_item< value $id$ = $v$ >>)
x1
in
let list2 =
List.map
(fun (l, v) ->
let id =
match l with
[ <:patt< $lid:l$ >> -> l
| _ -> "" ]
in
let loc = MLast.loc_of_patt l in
<:class_str_item< method $id$ = $lid:id$ >>)
x1
in
<:expr<
let module M =
struct
class a = object $list:list1 @ list2$ end;
end
in
new M.a
>>
;
value record_match_assoc loc lpl e =
if ocaml_records.val then (<:patt< { $list:lpl$ } >>, e)
else
let pl = List.map (fun (_, p) -> p) lpl in
let e =
let el =
List.map
(fun (l, _) ->
let s =
match l with
[ <:patt< $lid:l$ >> -> l
| _ -> "" ]
in
let loc = MLast.loc_of_patt l in
<:expr< v # $lid:s$ >>)
lpl
in
let loc = MLast.loc_of_expr e in
<:expr< let v = $e$ in ($list:el$) >>
in
let p = <:patt< ($list:pl$) >> in
(p, e)
;
value op =
Grammar.Entry.of_parser gram "op"
(parser [: `("", "op"); `(_, x) :] -> x)
;
lexer.Token.tok_using ("", "op");
value special x =
if String.length x >= 2 then
match x.[0] with
[ '+' | '<' | '^' -> True
| _ -> False ]
else False
;
value idd =
let p =
parser
[ [: `("LIDENT", x) :] -> x
| [: `("UIDENT", x) :] -> x
| [: `("", "op"); `(_, x) :] -> x
| [: `("", x) when special x :] -> x ]
in
Grammar.Entry.of_parser Pcaml.gram "ID" p
;
value uncap s = String.uncapitalize s;
EXTEND
GLOBAL: implem interf top_phrase use_file sig_item str_item ctyp patt expr
module_type module_expr;
implem:
[ [ x = interdec; EOI -> x ] ]
;
interf:
[ [ x = LIST1 [ s = sig_item; OPT ";" -> (s, loc) ] -> (x, False) ] ]
;
top_phrase:
[ [ ph = phrase; ";" -> Some ph
| EOI -> None ] ]
;
use_file:
[ [ l = LIST0 phrase; EOI -> (l, False) ] ]
;
phrase:
[ [ x = str_item -> x
| x = expr -> <:str_item< $exp:x$ >>
| "#"; n = LIDENT; dp = dir_param -> MLast.StDir loc n dp ] ]
;
dir_param:
[ [ -> None
| e = expr -> Some e ] ]
;
sdecs:
[ [ x = sdec; l = sdecs -> [x :: l]
| ";"; l = sdecs -> l
| -> [] ] ]
;
fsigb: [ [ -> not_impl loc "fsigb" ] ];
fsigconstraint_op: [ [ -> not_impl loc "fsigconstraint_op" ] ];
fct_exp: [ [ -> not_impl loc "fct_exp" ] ];
exp_pa: [ [ -> not_impl loc "exp_pa" ] ];
rvb: [ [ -> not_impl loc "rvb" ] ];
tyvarseq: [ [ -> not_impl loc "tyvarseq" ] ];
tyvar_pc:
[ [ "'"; x1 = LIDENT -> [(x1, (False, False))]
| "'"; x1 = LIDENT; ","; l = tyvar_pc -> [(x1, (False, False)) :: l] ] ]
;
id:
[ [ x1 = idd -> x1
| "*" -> "*" ] ]
;
ident:
[ [ x1 = idd -> x1
| "*" -> "*"
| "=" -> "="
| "<" -> "<"
| ">" -> ">"
| "<=" -> "<="
| ">=" -> ">="
| "^" -> "^" ] ]
;
op_op:
[ [ x1 = op -> not_impl loc "op_op 1"
| -> () ] ]
;
qid:
[ [ x1 = idd; "."; x2 = qid -> <:module_expr< $uid:x1$ . $x2$ >>
| x1 = idd -> <:module_expr< $uid:x1$ >>
| x1 = "*" -> <:module_expr< $uid:x1$ >>
| x1 = "=" -> <:module_expr< $uid:x1$ >> ] ]
;
eqid:
[ [ x1 = UIDENT; "."; x2 = eqid -> <:expr< $uid:x1$ . $x2$ >>
| x1 = UIDENT -> <:expr< $uid:x1$ >>
| x1 = idd -> <:expr< $lid:x1$ >>
| x1 = "*" -> <:expr< $lid:x1$ >>
| x1 = "=" -> <:expr< $lid:x1$ >> ] ]
;
sqid:
[ [ x1 = idd; "."; x2 = sqid -> [x1 :: x2]
| x1 = idd -> [x1]
| x1 = "*" -> [x1]
| x1 = "=" -> [x1] ] ]
;
tycon:
[ [ LIDENT "real" -> <:ctyp< float >>
| x1 = idd; "."; x2 = tycon ->
let r = <:ctyp< $uid:x1$ . $x2$ >> in
loop r where rec loop =
fun
[ <:ctyp< $a$ . ($b$ . $c$) >> -> <:ctyp< $a$ . $b$ . $loop c$ >>
| x -> x ]
| x1 = idd -> <:ctyp< $lid:uncap x1$ >> ] ]
;
selector:
[ [ x1 = id -> x1
| x1 = INT -> not_impl loc "selector 1" ] ]
;
tlabel:
[ [ x1 = selector; ":"; x2 = ctyp -> (loc, x1, False, x2) ] ]
;
tuple_ty:
[ [ x1 = ctyp LEVEL "ty'"; "*"; x2 = tuple_ty -> [x1 :: x2]
| x1 = ctyp LEVEL "ty'" -> [x1] ] ]
;
ctyp:
[ RIGHTA
[ x1 = ctyp; "->"; x2 = ctyp -> <:ctyp< $x1$ -> $x2$ >> ]
| [ x1 = ctyp; "*"; x2 = tuple_ty -> <:ctyp< ($list:[x1 :: x2]$) >> ]
| "ty'"
[ "'"; x1 = LIDENT -> <:ctyp< '$x1$ >>
| "'"; "'"; x1 = LIDENT -> <:ctyp< '$x1$ >>
| "{"; x1 = LIST1 tlabel SEP ","; "}" ->
if ocaml_records.val then <:ctyp< { $list:x1$ } >>
else
let list = List.map (fun (_, l, _, t) -> (l, t)) x1 in
<:ctyp< < $list:list$ > >>
| "{"; "}" -> not_impl loc "ty' 3"
| "("; x1 = ctyp; ","; x2 = LIST1 ctyp SEP ","; ")"; x3 = tycon ->
List.fold_left (fun t1 t2 -> <:ctyp< $t1$ $t2$ >>) x3 [x1 :: x2]
| "("; x1 = ctyp; ")" -> x1
| x1 = ctyp; x2 = tycon -> <:ctyp< $x2$ $x1$ >>
| x1 = tycon -> x1 ] ]
;
rule:
[ [ x1 = patt; "=>"; x2 = expr -> (x1, None, x2) ] ]
;
elabel:
[ [ x1 = selector; "="; x2 = expr -> (<:patt< $lid:x1$ >>, x2) ] ]
;
exp_ps:
[ [ x1 = expr -> x1
| x1 = expr; ";"; x2 = exp_ps ->
<:expr< do { $list:[x1 :: get_seq x2]$ } >> ] ]
;
expr:
[ [ "if"; x1 = expr; "then"; x2 = expr; "else"; x3 = expr ->
<:expr< if $x1$ then $x2$ else $x3$ >>
| "fn"; x1 = LIST1 rule SEP "|" -> <:expr< fun [$list:x1$] >>
| "case"; x1 = expr; "of"; x2 = LIST1 rule SEP "|" ->
<:expr< match $x1$ with [$list:x2$] >>
| "while"; x1 = expr; "do"; x2 = expr ->
<:expr< while $x1$ do { $x2$ } >>
| x1 = expr; "handle"; x2 = LIST1 rule SEP "|" ->
<:expr< try $x1$ with [$list:x2$] >> ]
| RIGHTA
[ "raise"; x1 = expr -> <:expr< raise $x1$ >> ]
| [ e1 = expr; ":="; e2 = expr -> <:expr< $e1$.val := $e2$ >> ]
| LEFTA
[ x1 = expr; "orelse"; x2 = expr -> <:expr< $x1$ || $x2$ >> ]
| LEFTA
[ x1 = expr; "andalso"; x2 = expr -> <:expr< $x1$ && $x2$ >> ]
| LEFTA
[ x1 = expr; ":"; x2 = ctyp -> <:expr< ($x1$ : $x2$) >> ]
| "4" NONA
[ x1 = expr; "<"; x2 = expr -> <:expr< $x1$ < $x2$ >>
| x1 = expr; ">"; x2 = expr -> <:expr< $x1$ > $x2$ >>
| x1 = expr; "<>"; x2 = expr -> <:expr< $x1$ <> $x2$ >>
| x1 = expr; "="; x2 = expr -> <:expr< $x1$ = $x2$ >>
| x1 = expr; ">="; x2 = expr -> <:expr< $x1$ >= $x2$ >>
| x1 = expr; "<="; x2 = expr -> <:expr< $x1$ <= $x2$ >> ]
| RIGHTA
[ x1 = expr; "^"; x2 = expr -> <:expr< $x1$ ^ $x2$ >>
| x1 = expr; "@"; x2 = expr -> <:expr< $x1$ @ $x2$ >>
| x1 = expr; "o"; x2 = expr -> <:expr< ooo $x1$ $x2$ >> ]
| "5" RIGHTA
[ x1 = expr; "::"; x2 = expr -> <:expr< [$x1$ :: $x2$] >> ]
| "6" LEFTA
[ x1 = expr; "+"; x2 = expr -> <:expr< $x1$ + $x2$ >>
| x1 = expr; "-"; x2 = expr -> <:expr< $x1$ - $x2$ >> ]
| "7" LEFTA
[ x1 = expr; "*"; x2 = expr -> <:expr< $x1$ * $x2$ >>
| x1 = expr; "/"; x2 = expr -> <:expr< $x1$ / $x2$ >>
| x1 = expr; "div"; x2 = expr -> <:expr< $x1$ / $x2$ >>
| x1 = expr; "mod"; x2 = expr -> <:expr< $x1$ mod $x2$ >> ]
| LEFTA
[ x1 = expr; x2 = expr -> <:expr< $x1$ $x2$ >> ]
| [ "#"; x1 = STRING -> <:expr< $chr:x1$ >>
| "#"; x1 = selector; x2 = expr ->
if ocaml_records.val then <:expr< $x2$ . $lid:x1$ >>
else <:expr< $x2$ # $lid:x1$ >>
| x1 = expr; "ocaml_record_access"; x2 = expr -> <:expr< $x1$ . $x2$ >> ]
| [ "!"; x1 = expr -> <:expr< $x1$ . val >>
| "~"; x1 = expr -> <:expr< - $x1$ >> ]
| [ x1 = LIDENT ->
match x1 with
[ "true" | "false" -> <:expr< $uid:String.capitalize x1$ >>
| "nil" -> <:expr< [] >>
| _ -> <:expr< $lid:x1$ >> ]
| x1 = UIDENT -> <:expr< $uid:x1$ >>
| x1 = UIDENT; "."; x2 = eqid -> <:expr< $uid:x1$ . $x2$ >>
| x1 = INT -> <:expr< $int:x1$ >>
| x1 = FLOAT -> <:expr< $flo:x1$ >>
| x1 = STRING -> <:expr< $str:x1$ >>
| "~"; x1 = INT -> <:expr< $int:"-"^x1$ >>
| i = op ->
if i = "::" then <:expr< fun (x, y) -> [x :: y] >>
else <:expr< fun (x, y) -> $lid:i$ x y >>
| "let"; x1 = ldecs; "in"; x2 = exp_ps; "end" ->
List.fold_right
(fun pel x2 ->
let loc =
match pel with
[ [(p, _) :: _] ->
(fst (MLast.loc_of_patt p), snd (MLast.loc_of_expr x2))
| _ -> loc ]
in
match pel with
[ [(_, <:expr< fun [$list:_$] >>) :: _] ->
<:expr< let rec $list:pel$ in $x2$ >>
| _ ->
let pel =
List.map
(fun (p, e) ->
match p with
[ <:patt< { $list:lpl$ } >> ->
record_match_assoc (MLast.loc_of_patt p) lpl e
| _ -> (p, e) ])
pel
in
<:expr< let $list:pel$ in $x2$ >> ])
x1 x2
| "{"; x1 = LIST1 elabel SEP ","; "}" -> record_expr loc x1
| "["; "]" -> <:expr< [] >>
| "["; x1 = expr; "]" -> <:expr< [$x1$] >>
| "["; x1 = expr; ","; x2 = LIST1 SELF SEP ","; "]" ->
mklistexp loc None [x1 :: x2]
| "("; ")" -> <:expr< () >>
| "("; x1 = expr; ","; x2 = LIST1 SELF SEP ","; ")" ->
<:expr< ($list:[x1::x2]$) >>
| "("; x1 = expr; ";"; x2 = LIST1 SELF SEP ";"; ")" ->
<:expr< do { $list:[x1::x2]$ } >>
| "("; x1 = expr; ")" -> x1 ] ]
;
fixity:
[ [ "infix" -> ("infix", None)
| "infix"; x1 = INT -> not_impl loc "fixity 2"
| "infixr" -> not_impl loc "fixity 3"
| "infixr"; x1 = INT -> ("infixr", Some x1)
| "nonfix" -> not_impl loc "fixity 5" ] ]
;
patt:
[ [ x1 = patt; "as"; x2 = patt -> <:patt< ($x1$ as $x2$) >> ]
| LEFTA
[ x1 = patt; ":"; x2 = ctyp -> <:patt< ($x1$ : $x2$) >> ]
| RIGHTA
[ x1 = patt; "::"; x2 = patt -> <:patt< [$x1$ :: $x2$] >> ]
| [ x1 = patt; x2 = patt ->
match x1 with
[ <:patt< ref >> -> <:patt< {contents = $x2$} >>
| _ -> <:patt< $x1$ $x2$ >> ] ]
| "apat"
[ x1 = patt; "."; x2 = patt -> <:patt< $x1$ . $x2$ >>
| x1 = INT -> <:patt< $int:x1$ >>
| x1 = UIDENT -> <:patt< $uid:x1$ >>
| x1 = STRING -> <:patt< $str:x1$ >>
| "#"; x1 = STRING -> <:patt< $chr:x1$ >>
| "~"; x1 = INT -> <:patt< $int:"-"^x1$ >>
| LIDENT "nil" -> <:patt< [] >>
| LIDENT "false" -> <:patt< False >>
| LIDENT "true" -> <:patt< True >>
| x1 = id -> <:patt< $lid:x1$ >>
| x1 = op -> <:patt< $lid:x1$ >>
| "_" -> <:patt< _ >>
| "["; "]" -> <:patt< [] >>
| "["; x1 = patt; "]" -> <:patt< [$x1$] >>
| "["; x1 = patt; ","; x2 = LIST1 SELF SEP ","; "]" ->
mklistpat loc None [x1 :: x2]
| "{"; x1 = LIST1 plabel SEP ","; "}" -> <:patt< {$list:x1$} >>
| "("; ")" -> <:patt< () >>
| "("; x1 = patt; ","; x2 = LIST1 SELF SEP ","; ")" ->
<:patt< ($list:[x1::x2]$) >>
| "("; x1 = patt; ")" -> x1 ] ]
;
plabel:
[ [ x1 = selector; "="; x2 = patt -> (<:patt< $lid:x1$ >>, x2)
| x1 = selector -> (<:patt< $lid:x1$ >>, <:patt< $lid:x1$ >>) ] ]
;
vb:
[ [ "lazy"; x1 = patt; "="; x2 = expr -> not_impl loc "vb 1"
| x1 = patt; "="; x2 = expr -> (x1, x2) ] ]
;
constrain:
[ [ -> None
| ":"; x1 = ctyp -> Some x1 ] ]
;
fb:
[ [ xl = LIST1 clause SEP "|" -> function_of_clause_list loc xl
| "lazy"; x1 = LIST1 clause SEP "|" -> not_impl loc "fb 2" ] ]
;
clause:
[ [ x1 = patt LEVEL "apat"; x2 = LIST1 (patt LEVEL "apat");
x3 = constrain; "="; x4 = expr ->
let x1 =
match x1 with
[ <:patt< $lid:id$ >> -> (id, MLast.loc_of_patt x1)
| _ -> not_impl loc "clause 1" ]
in
(x1, x2, x3, x4) ] ]
;
tb:
[ [ x1 = tyvars; x2 = idd; "="; x3 = ctyp ->
((loc, uncap x2), x1, x3, [])
| x1 = tyvars; x2 = idd; "="; x3 = ctyp; "=="; x4 = dbrhs ->
let x4 = List.map (fun (loc, c, tl, _) -> (loc, c, tl)) x4 in
((loc, uncap x2), x1, <:ctyp< $x3$ == [ $list:x4$ ] >>, []) ] ]
;
tyvars:
[ [ "'"; x1 = LIDENT -> [(x1, (False, False))]
| "("; x1 = tyvar_pc; ")" -> x1
| -> [] ] ]
;
db1:
[ [ x1 = tyvars; x2 = ident; "="; x3 = dbrhs ->
let x2 = uncap x2 in
extract_label_types loc x2 x1 x3
| "lazy"; x1 = tyvars; x2 = ident; "="; x3 = dbrhs ->
not_impl loc "db 2" ] ]
;
db:
[ [ x1 = LIST1 db1 SEP "and" ->
List.fold_right (fun td tdl -> td @ tdl) x1 [] ] ]
;
dbrhs:
[ [ x1 = LIST1 constr SEP "|" -> x1
| "datatype"; x1 = tycon -> not_impl loc "dbrhs 2" ] ]
;
constr:
[ [ x1 = op_op; x2 = ident -> (loc, x2, [], None)
| x1 = op_op; x2 = ident; "of"; x3 = ctyp ->
match x3 with
[ <:ctyp< {$list:_$} >> -> (loc, x2, [], Some x3)
| _ -> (loc, x2, [x3], None) ] ] ]
;
eb:
[ [ x1 = op_op; x2 = ident -> (x2, [], [])
| x1 = op_op; x2 = ident; "of"; x3 = ctyp -> (x2, [x3], [])
| x1 = op_op; x2 = ident; "="; x3 = sqid -> (x2, [], x3) ] ]
;
ldec1:
[ [ "val"; x1 = LIST1 vb SEP "and" -> x1
| "fun"; x1 = LIST1 fb SEP "and" -> x1 ] ]
;
ldecs:
[ [ -> []
| x1 = ldec1; x2 = ldecs -> [x1 :: x2]
| ";"; x1 = ldecs -> x1
| "local"; x1 = ldecs; "in"; x2 = ldecs; "end"; x3 = ldecs ->
not_impl loc "ldecs 4" ] ]
;
spec_s:
[ [ -> []
| x1 = spec; x2 = spec_s -> [x1 :: x2]
| ";"; x1 = spec_s -> x1 ] ]
;
spec:
[ [ "structure"; x1 = LIST1 strspec SEP "and" -> sig_declare loc x1
| "functor"; x1 = LIST1 fctspec SEP "and" -> sig_declare loc x1
| "datatype"; x1 = db -> <:sig_item< type $list:x1$ >>
| "type"; x1 = LIST1 tyspec SEP "and" -> <:sig_item< type $list:x1$ >>
| "eqtype"; x1 = LIST1 tyspec SEP "and" -> <:sig_item< type $list:x1$ >>
| "val"; x1 = LIST1 valspec SEP "and" -> sig_declare loc x1
| "exception"; x1 = LIST1 exnspec SEP "and" -> sig_declare loc x1
| "sharing"; x1 = LIST1 sharespec SEP "and" -> <:sig_item< declare end >>
| "include"; x1 = module_type -> <:sig_item< include $x1$ >> ] ]
;
sig_item:
[ [ x = spec -> x ] ]
;
strspec:
[ [ x1 = ident; ":"; x2 = module_type; x3 = LIST0 sharing_def ->
let x2 =
List.fold_left
(fun mt sdl ->
List.fold_right
(fun spl mt ->
match spl with
[ Right ([m1], m2) ->
let (m1, m2) =
match m2 with
[ <:module_expr< $uid:x$ . $_$ >> ->
if x = x1 then (m2, m1) else (m1, m2)
| _ -> (m1, m2) ]
in
let m1 =
loop m1 where rec loop =
fun
[ <:module_expr< $uid:x$ >> -> x
| <:module_expr< $uid:x$ . $y$ >> -> loop y
| _ -> not_impl loc "strspec 2" ]
in
<:module_type< $mt$ with module $[m1]$ = $m2$ >>
| _ -> not_impl loc "strspec 1" ])
sdl mt)
x2 x3
in
<:sig_item< module $x1$ : $x2$ >> ] ]
;
sharing_def:
[ [ "sharing"; x3 = LIST1 sharespec SEP "and" -> x3 ] ]
;
fctspec:
[ [ x1 = ident; x2 = fsig -> <:sig_item< module $x1$ : $x2$ >> ] ]
;
tyspec:
[ [ x1 = tyvars; x2 = idd ->
((loc, uncap x2), x1, <:ctyp< '$choose_tvar x1$ >>, [])
| x1 = tyvars; x2 = idd; "="; x3 = ctyp ->
((loc, uncap x2), x1, x3, []) ] ]
;
valspec:
[ [ x1 = op_op; x2 = ident; ":"; x3 = ctyp ->
<:sig_item< value $x2$ : $x3$ >> ] ]
;
exnspec:
[ [ x1 = ident -> <:sig_item< exception $x1$ >>
| x1 = ident; "of"; x2 = ctyp ->
<:sig_item< exception $x1$ of $x2$ >> ] ]
;
sharespec:
[ [ "type"; x1 = patheqn -> Left x1
| x1 = patheqn -> Right x1 ] ]
;
patheqn:
[ [ l = patheqn1 -> l ] ]
;
patheqn1:
[ [ (l, y) = patheqn1; "="; x = qid -> ([y :: l], x)
| x = qid -> ([], x) ] ]
;
whspec:
[ [ "type"; x1 = tyvars; x2 = sqid; "="; x3 = ctyp ->
MLast.WcTyp loc x2 x1 x3
| x1 = sqid; "="; x2 = qid -> MLast.WcMod loc x1 x2 ] ]
;
module_type:
[ [ x1 = ident -> <:module_type< $uid:x1$ >>
| "sig"; x1 = spec_s; "end" -> <:module_type< sig $list:x1$ end >>
| x1 = module_type; "where"; x2 = LIST1 whspec SEP "and" ->
<:module_type< $x1$ with $list:x2$ >> ] ]
;
sigconstraint_op:
[ [ -> None
| ":"; x1 = module_type -> Some x1
| ":>"; x1 = module_type -> not_impl loc "sigconstraint_op 3" ] ]
;
sigb:
[ [ x1 = ident; "="; x2 = module_type ->
<:str_item< module type $x1$ = $x2$ >> ] ]
;
fsig:
[ [ ":"; x1 = ident -> not_impl loc "fsig 1"
| x1 = fparamList; ":"; x2 = module_type -> not_impl loc "fsig 2" ] ]
;
module_expr:
[ [ x1 = qid -> x1
| "struct"; x1 = strdecs; "end" -> <:module_expr< struct $list:x1$ end >>
| x1 = qid; x2 = arg_fct ->
match x2 with
[ Left [] -> x1
| Left x2 -> <:module_expr< $x1$ (struct $list:x2$ end) >>
| Right x2 -> <:module_expr< $x1$ $x2$ >> ]
| "let"; x1 = strdecs; "in"; x2 = module_expr; "end" ->
not_impl loc "str 4"
| x1 = module_expr; ":"; x2 = module_type -> not_impl loc "str 5"
| x1 = module_expr; x2 = ":>"; x3 = module_type ->
not_impl loc "str 6" ] ]
;
arg_fct:
[ [ "("; x1 = strdecs; ")"; x2 = arg_fct -> not_impl loc "arg_fct 1"
| "("; x1 = module_expr; ")"; x2 = arg_fct -> not_impl loc "arg_fct 2"
| "("; x1 = module_expr; ")" -> Right x1
| "("; x2 = strdecs; ")" -> Left x2 ] ]
;
strdecs:
[ [ x1 = str_item LEVEL "strdec"; x2 = strdecs -> [x1 :: x2]
| ";"; x1 = strdecs -> x1
| -> [] ] ]
;
str_item:
[ [ "signature"; x1 = LIST1 sigb SEP "and" -> str_declare loc x1
| "funsig"; x1 = fsigb -> not_impl loc "sdec 3" ]
| "strdec"
[ "structure"; x1 = LIST1 strb SEP "and" -> str_declare loc x1
| "functor"; x1 = LIST1 fctb SEP "and" -> str_declare loc x1
| "local"; x1 = sdecs; "in"; x2 = sdecs; "end" ->
make_local loc x1 x2 ]
| [ "val"; x1 = LIST1 vb SEP "and" -> <:str_item< value $list:x1$ >>
| "val"; x1 = tyvarseq; x3 = LIST1 vb SEP "and" ->
not_impl loc "ldec 2"
| "val"; "rec"; x1 = rvb -> not_impl loc "ldec 3"
| "val"; "rec"; x1 = tyvarseq; x2 = rvb -> not_impl loc "ldec 4"
| "fun"; x1 = LIST1 fb SEP "and" -> <:str_item< value rec $list:x1$ >>
| "fun"; x1 = tyvarseq; x2 = fb -> not_impl loc "ldec 6"
| "type"; x1 = LIST1 tb SEP "and" -> <:str_item< type $list:x1$ >>
| "datatype"; x1 = db -> <:str_item< type $list:x1$ >>
| "datatype"; x1 = db; "withtype"; x2 = tb ->
<:str_item< type $list:x1 @ [x2]$ >>
| "abstype"; x1 = db; "with"; x2 = ldecs; "end" -> not_impl loc "ldec 10"
| "abstype"; x1 = db; "withtype"; x2 = tb; "with"; x3 = ldecs; "end" ->
not_impl loc "ldec 11"
| "exception"; x1 = LIST1 eb SEP "and" ->
let dl =
List.map
(fun (s, tl, eqn) ->
<:str_item< exception $s$ of $list:tl$ = $eqn$ >>)
x1
in
str_declare loc dl
| "open"; x1 = LIST1 sqid ->
let dl = List.map (fun sl -> <:str_item< open $sl$ >>) x1 in
str_declare loc dl
| LIDENT "use"; s = STRING ->
<:str_item< #use $str:s$ >>
| x1 = fixity; list = LIST1 idd ->
match x1 with
[ ("infixr", Some n) ->
do {
List.iter
(fun s ->
EXTEND
expr: LEVEL $n$
[ [ x1 = expr; $s$; x2 = expr ->
<:expr< $lid:s$ ($x1$, $x2$) >> ] ]
;
END)
list;
str_declare loc []
}
| ("infix", None) ->
do {
List.iter
(fun s ->
EXTEND
expr: LEVEL "4"
[ [ x1 = expr; $s$; x2 = expr ->
<:expr< $lid:s$ ($x1$, $x2$) >> ] ]
;
clause:
[ [ x1 = patt LEVEL "apat"; $s$;
x2 = patt LEVEL "apat"; "="; x4 = expr ->
((s, loc), [<:patt< ($x1$, $x2$) >>],
None, x4) ] ]
;
END)
list;
str_declare loc []
}
| _ -> not_impl loc "ldec 14" ]
| "overload"; x1 = ident; ":"; x2 = ctyp; "as"; x3 = exp_pa ->
not_impl loc "ldec 15"
| x = expr -> <:str_item< $exp:x$ >> ] ]
;
sdec:
[ [ x = str_item -> x ] ]
;
strb:
[ [ x1 = ident; x2 = sigconstraint_op; "="; x3 = module_expr ->
let x3 =
match x2 with
[ Some x2 -> <:module_expr< ($x3$ : $x2$) >>
| None -> x3 ]
in
<:str_item< module $x1$ = $x3$ >> ] ]
;
fparam:
[ [ x1 = idd; ":"; x2 = module_type -> [<:sig_item< module $x1$ : $x2$ >>]
| x1 = spec_s -> x1 ] ]
;
fparamList:
[ [ "("; x1 = fparam; ")" -> [x1]
| "("; x1 = fparam; ")"; x2 = fparamList -> [x1 :: x2] ] ]
;
fctb:
[ [ x1 = ident; x2 = fparamList; x3 = sigconstraint_op; "=";
x4 = module_expr ->
let list = List.flatten x2 in
let x4 =
if list = [] then x4
else
match x4 with
[ <:module_expr< struct $list:list$ end >> ->
let si =
let loc = (Token.nowhere, Token.nowhere) in
<:str_item< open AAA >> in
<:module_expr< struct $list:[si :: list]$ end >>
| _ -> not_impl loc "fctb 1" ]
in
let x4 =
match x3 with
[ Some x3 -> <:module_expr< ($x4$ : $x3$) >>
| None -> x4 ]
in
let x4 =
if list = [] then x4
else
let mt =
let loc =
(fst (MLast.loc_of_sig_item (List.hd list)),
snd (MLast.loc_of_sig_item (List.hd (List.rev list))))
in
<:module_type< sig $list:list$ end >>
in
<:module_expr< functor (AAA : $mt$) -> $x4$ >>
in
<:str_item< module $x1$ = $x4$ >>
| x1 = ident; x2 = fsigconstraint_op; "="; x3 = fct_exp ->
not_impl loc "fctb 2" ] ]
;
interdec:
[ [ x = LIST1 [ s = str_item; OPT ";" -> (s, loc) ] -> (x, False)
| x = expr; OPT ";" -> not_impl loc "interdec 2" ] ]
;
END;
Pcaml.add_option "-records" (Arg.Set ocaml_records)
"Convert record into OCaml records, instead of objects";

813
camlp4/etc/pr_scheme.ml
View File

@ -1,813 +0,0 @@
(* camlp4r q_MLast.cmo ./pa_extfun.cmo *)
(* $Id$ *)
open Pcaml;
open Format;
type printer_t 'a =
{ pr_fun : mutable string -> next 'a;
pr_levels : mutable list (pr_level 'a) }
and pr_level 'a =
{ pr_label : string;
pr_box : formatter -> (formatter -> unit) -> 'a -> unit;
pr_rules : mutable pr_rule 'a }
and pr_rule 'a =
Extfun.t 'a (formatter -> curr 'a -> next 'a -> string -> kont -> unit)
and curr 'a = formatter -> ('a * string * kont) -> unit
and next 'a = formatter -> ('a * string * kont) -> unit
and kont = formatter -> unit;
value not_impl name x ppf k =
let desc =
if Obj.is_block (Obj.repr x) then
"tag = " ^ string_of_int (Obj.tag (Obj.repr x))
else "int_val = " ^ string_of_int (Obj.magic x)
in
fprintf ppf "<pr_scheme: not impl: %s; %s>%t" name desc k
;
value pr_fun name pr lab =
loop False pr.pr_levels where rec loop app =
fun
[ [] -> fun ppf (x, dg, k) -> failwith ("unable to print " ^ name)
| [lev :: levl] ->
if app || lev.pr_label = lab then
let next = loop True levl in
let rec curr ppf (x, dg, k) =
Extfun.apply lev.pr_rules x ppf curr next dg k
in
fun ppf ((x, _, _) as n) -> lev.pr_box ppf (fun ppf -> curr ppf n) x
else loop app levl ]
;
value rec find_pr_level lab =
fun
[ [] -> failwith ("level " ^ lab ^ " not found")
| [lev :: levl] ->
if lev.pr_label = lab then lev else find_pr_level lab levl ]
;
value pr_constr_decl = {pr_fun = fun []; pr_levels = []};
value constr_decl ppf (x, k) = pr_constr_decl.pr_fun "top" ppf (x, "", k);
pr_constr_decl.pr_fun := pr_fun "constr_decl" pr_constr_decl;
value pr_ctyp = {pr_fun = fun []; pr_levels = []};
pr_ctyp.pr_fun := pr_fun "ctyp" pr_ctyp;
value ctyp ppf (x, k) = pr_ctyp.pr_fun "top" ppf (x, "", k);
value pr_expr = {pr_fun = fun []; pr_levels = []};
pr_expr.pr_fun := pr_fun "expr" pr_expr;
value expr ppf (x, k) = pr_expr.pr_fun "top" ppf (x, "", k);
value pr_label_decl = {pr_fun = fun []; pr_levels = []};
value label_decl ppf (x, k) = pr_label_decl.pr_fun "top" ppf (x, "", k);
pr_label_decl.pr_fun := pr_fun "label_decl" pr_label_decl;
value pr_let_binding = {pr_fun = fun []; pr_levels = []};
pr_let_binding.pr_fun := pr_fun "let_binding" pr_let_binding;
value let_binding ppf (x, k) = pr_let_binding.pr_fun "top" ppf (x, "", k);
value pr_match_assoc = {pr_fun = fun []; pr_levels = []};
pr_match_assoc.pr_fun := pr_fun "match_assoc" pr_match_assoc;
value match_assoc ppf (x, k) = pr_match_assoc.pr_fun "top" ppf (x, "", k);
value pr_mod_ident = {pr_fun = fun []; pr_levels = []};
pr_mod_ident.pr_fun := pr_fun "mod_ident" pr_mod_ident;
value mod_ident ppf (x, k) = pr_mod_ident.pr_fun "top" ppf (x, "", k);
value pr_module_binding = {pr_fun = fun []; pr_levels = []};
pr_module_binding.pr_fun := pr_fun "module_binding" pr_module_binding;
value module_binding ppf (x, k) =
pr_module_binding.pr_fun "top" ppf (x, "", k);
value pr_module_expr = {pr_fun = fun []; pr_levels = []};
pr_module_expr.pr_fun := pr_fun "module_expr" pr_module_expr;
value module_expr ppf (x, k) = pr_module_expr.pr_fun "top" ppf (x, "", k);
value pr_module_type = {pr_fun = fun []; pr_levels = []};
pr_module_type.pr_fun := pr_fun "module_type" pr_module_type;
value module_type ppf (x, k) = pr_module_type.pr_fun "top" ppf (x, "", k);
value pr_patt = {pr_fun = fun []; pr_levels = []};
pr_patt.pr_fun := pr_fun "patt" pr_patt;
value patt ppf (x, k) = pr_patt.pr_fun "top" ppf (x, "", k);
value pr_sig_item = {pr_fun = fun []; pr_levels = []};
pr_sig_item.pr_fun := pr_fun "sig_item" pr_sig_item;
value sig_item ppf (x, k) = pr_sig_item.pr_fun "top" ppf (x, "", k);
value pr_str_item = {pr_fun = fun []; pr_levels = []};
pr_str_item.pr_fun := pr_fun "str_item" pr_str_item;
value str_item ppf (x, k) = pr_str_item.pr_fun "top" ppf (x, "", k);
value pr_type_decl = {pr_fun = fun []; pr_levels = []};
value type_decl ppf (x, k) = pr_type_decl.pr_fun "top" ppf (x, "", k);
pr_type_decl.pr_fun := pr_fun "type_decl" pr_type_decl;
value pr_type_params = {pr_fun = fun []; pr_levels = []};
value type_params ppf (x, k) = pr_type_params.pr_fun "top" ppf (x, "", k);
pr_type_params.pr_fun := pr_fun "type_params" pr_type_params;
value pr_with_constr = {pr_fun = fun []; pr_levels = []};
value with_constr ppf (x, k) = pr_with_constr.pr_fun "top" ppf (x, "", k);
pr_with_constr.pr_fun := pr_fun "with_constr" pr_with_constr;
(* general functions *)
value nok ppf = ();
value ks s k ppf = fprintf ppf "%s%t" s k;
value rec list f ppf (l, k) =
match l with
[ [] -> k ppf
| [x] -> f ppf (x, k)
| [x :: l] -> fprintf ppf "%a@ %a" f (x, nok) (list f) (l, k) ]
;
value rec listwb b f ppf (l, k) =
match l with
[ [] -> k ppf
| [x] -> f ppf ((b, x), k)
| [x :: l] -> fprintf ppf "%a@ %a" f ((b, x), nok) (listwb "" f) (l, k) ]
;
(* specific functions *)
value rec is_irrefut_patt =
fun
[ <:patt< $lid:_$ >> -> True
| <:patt< () >> -> True
| <:patt< _ >> -> True
| <:patt< ($x$ as $y$) >> -> is_irrefut_patt x && is_irrefut_patt y
| <:patt< { $list:fpl$ } >> ->
List.for_all (fun (_, p) -> is_irrefut_patt p) fpl
| <:patt< ($p$ : $_$) >> -> is_irrefut_patt p
| <:patt< ($list:pl$) >> -> List.for_all is_irrefut_patt pl
| <:patt< ? $_$ : ( $p$ ) >> -> is_irrefut_patt p
| <:patt< ? $_$ : ($p$ = $_$) >> -> is_irrefut_patt p
| <:patt< ~ $_$ >> -> True
| <:patt< ~ $_$ : $p$ >> -> is_irrefut_patt p
| _ -> False ]
;
value expr_fun_args ge = Extfun.apply pr_expr_fun_args.val ge;
pr_expr_fun_args.val :=
extfun Extfun.empty with
[ <:expr< fun [$p$ -> $e$] >> as ge ->
if is_irrefut_patt p then
let (pl, e) = expr_fun_args e in
([p :: pl], e)
else ([], ge)
| ge -> ([], ge) ];
value sequence ppf (e, k) =
match e with
[ <:expr< do { $list:el$ } >> ->
fprintf ppf "@[<hv>%a@]" (list expr) (el, k)
| _ -> expr ppf (e, k) ]
;
value string ppf (s, k) = fprintf ppf "\"%s\"%t" s k;
value int_repr s =
if String.length s > 2 && s.[0] = '0' then
match s.[1] with
[ 'b' | 'o' | 'x' | 'B' | 'O' | 'X' ->
"#" ^ String.sub s 1 (String.length s - 1)
| _ -> s ]
else s
;
value assoc_left_parsed_op_list = ["+"; "*"; "land"; "lor"; "lxor"];
value assoc_right_parsed_op_list = ["and"; "or"; "^"; "@"];
value and_by_couple_op_list = ["="; "<>"; "<"; ">"; "<="; ">="; "=="; "!="];
(* extensible pretty print functions *)
pr_constr_decl.pr_levels :=
[{pr_label = "top";
pr_box ppf f x = fprintf ppf "@[%t@]" f;
pr_rules =
extfun Extfun.empty with
[ (loc, c, []) as x ->
fun ppf curr next dg k -> fprintf ppf "(@[<hv>%s%t@]" c (ks ")" k)
| (loc, c, tl) ->
fun ppf curr next dg k ->
fprintf ppf "(@[<hv>%s@ %a@]" c (list ctyp) (tl, ks ")" k) ]}];
pr_ctyp.pr_levels :=
[{pr_label = "top";
pr_box ppf f x = fprintf ppf "@[%t@]" f;
pr_rules =
extfun Extfun.empty with
[ <:ctyp< [ $list:cdl$ ] >> ->
fun ppf curr next dg k ->
fprintf ppf "(@[<hv>sum@ %a@]" (list constr_decl) (cdl, ks ")" k)
| <:ctyp< { $list:cdl$ } >> ->
fun ppf curr next dg k ->
fprintf ppf "{@[<hv>%a@]" (list label_decl) (cdl, ks "}" k)
| <:ctyp< ( $list:tl$ ) >> ->
fun ppf curr next dg k ->
fprintf ppf "(@[* @[<hv>%a@]@]" (list ctyp) (tl, ks ")" k)
| <:ctyp< $t1$ -> $t2$ >> ->
fun ppf curr next dg k ->
let tl =
loop t2 where rec loop =
fun
[ <:ctyp< $t1$ -> $t2$ >> -> [t1 :: loop t2]
| t -> [t] ]
in
fprintf ppf "(@[-> @[<hv>%a@]@]" (list ctyp)
([t1 :: tl], ks ")" k)
| <:ctyp< $t1$ $t2$ >> ->
fun ppf curr next dg k ->
let (t, tl) =
loop [t2] t1 where rec loop tl =
fun
[ <:ctyp< $t1$ $t2$ >> -> loop [t2 :: tl] t1
| t1 -> (t1, tl) ]
in
fprintf ppf "(@[%a@ %a@]" ctyp (t, nok) (list ctyp) (tl, ks ")" k)
| <:ctyp< $t1$ . $t2$ >> ->
fun ppf curr next dg k ->
fprintf ppf "%a.%a" ctyp (t1, nok) ctyp (t2, k)
| <:ctyp< $lid:s$ >> | <:ctyp< $uid:s$ >> ->
fun ppf curr next dg k -> fprintf ppf "%s%t" s k
| <:ctyp< ' $s$ >> ->
fun ppf curr next dg k -> fprintf ppf "'%s%t" s k
| <:ctyp< _ >> ->
fun ppf curr next dg k -> fprintf ppf "_%t" k
| x ->
fun ppf curr next dg k -> not_impl "ctyp" x ppf k ]}];
pr_expr.pr_levels :=
[{pr_label = "top";
pr_box ppf f x = fprintf ppf "@[%t@]" f;
pr_rules =
extfun Extfun.empty with
[ <:expr< fun [] >> ->
fun ppf curr next dg k ->
fprintf ppf "(lambda%t" (ks ")" k)
| <:expr< fun $lid:s$ -> $e$ >> ->
fun ppf curr next dg k ->
fprintf ppf "(lambda@ %s@;<1 1>%a" s expr (e, ks ")" k)
| <:expr< fun [ $list:pwel$ ] >> ->
fun ppf curr next dg k ->
fprintf ppf "(@[<hv>lambda_match@ %a@]" (list match_assoc)
(pwel, ks ")" k)
| <:expr< match $e$ with [ $list:pwel$ ] >> ->
fun ppf curr next dg k ->
fprintf ppf "(@[<hv>@[<b 2>match@ %a@]@ %a@]" expr (e, nok)
(list match_assoc) (pwel, ks ")" k)
| <:expr< try $e$ with [ $list:pwel$ ] >> ->
fun ppf curr next dg k ->
fprintf ppf "(@[<hv>@[<b 2>try@ %a@]@ %a@]" expr (e, nok)
(list match_assoc) (pwel, ks ")" k)
| <:expr< let $p1$ = $e1$ in $e2$ >> ->
fun ppf curr next dg k ->
let (pel, e) =
loop [(p1, e1)] e2 where rec loop pel =
fun
[ <:expr< let $p1$ = $e1$ in $e2$ >> ->
loop [(p1, e1) :: pel] e2
| e -> (List.rev pel, e) ]
in
let b =
match pel with
[ [_] -> "let"
| _ -> "let*" ]
in
fprintf ppf "(@[@[%s (@[<v>%a@]@]@;<1 2>%a@]" b
(listwb "" let_binding) (pel, ks ")" nok)
sequence (e, ks ")" k)
| <:expr< let $opt:rf$ $list:pel$ in $e$ >> ->
fun ppf curr next dg k ->
let b = if rf then "letrec" else "let" in
fprintf ppf "(@[<hv>%s@ (@[<hv>%a@]@ %a@]" b
(listwb "" let_binding) (pel, ks ")" nok) expr (e, ks ")" k)
| <:expr< if $e1$ then $e2$ else () >> ->
fun ppf curr next dg k ->
fprintf ppf "(if @[%a@;<1 0>%a@]" expr (e1, nok)
expr (e2, ks ")" k)
| <:expr< if $e1$ then $e2$ else $e3$ >> ->
fun ppf curr next dg k ->
fprintf ppf "(if @[%a@ %a@ %a@]" expr (e1, nok)
expr (e2, nok) expr (e3, ks ")" k)
| <:expr< do { $list:el$ } >> ->
fun ppf curr next dg k ->
fprintf ppf "(begin@;<1 1>@[<hv>%a@]" (list expr) (el, ks ")" k)
| <:expr< for $i$ = $e1$ to $e2$ do { $list:el$ } >> ->
fun ppf curr next dg k ->
fprintf ppf "(@[for %s@ %a@ %a %a@]" i expr (e1, nok)
expr (e2, nok) (list expr) (el, ks ")" k)
| <:expr< ($e$ : $t$) >> ->
fun ppf curr next dg k ->
fprintf ppf "(:@ %a@ %a" expr (e, nok) ctyp (t, ks ")" k)
| <:expr< ($list:el$) >> ->
fun ppf curr next dg k ->
fprintf ppf "(values @[%a@]" (list expr) (el, ks ")" k)
| <:expr< { $list:fel$ } >> ->
fun ppf curr next dg k ->
let record_binding ppf ((p, e), k) =
fprintf ppf "(@[%a@ %a@]" patt (p, nok) expr (e, ks ")" k)
in
fprintf ppf "{@[<hv>%a@]" (list record_binding) (fel, ks "}" k)
| <:expr< { ($e$) with $list:fel$ } >> ->
fun ppf curr next dg k ->
let record_binding ppf ((p, e), k) =
fprintf ppf "(@[%a@ %a@]" patt (p, nok) expr (e, ks ")" k)
in
fprintf ppf "{@[@[with@ %a@]@ @[%a@]@]" expr (e, nok)
(list record_binding) (fel, ks "}" k)
| <:expr< $e1$ := $e2$ >> ->
fun ppf curr next dg k ->
fprintf ppf "(:=@;<1 1>%a@;<1 1>%a" expr (e1, nok)
expr (e2, ks ")" k)
| <:expr< [$_$ :: $_$] >> as e ->
fun ppf curr next dg k ->
let (el, c) =
make_list e where rec make_list e =
match e with
[ <:expr< [$e$ :: $y$] >> ->
let (el, c) = make_list y in
([e :: el], c)
| <:expr< [] >> -> ([], None)
| x -> ([], Some e) ]
in
match c with
[ None ->
fprintf ppf "[%a" (list expr) (el, ks "]" k)
| Some x ->
fprintf ppf "[%a@ %a" (list expr) (el, ks " ." nok)
expr (x, ks "]" k) ]
| <:expr< lazy ($x$) >> ->
fun ppf curr next dg k ->
fprintf ppf "(@[lazy@ %a@]" expr (x, ks ")" k)
| <:expr< $lid:s$ $e1$ $e2$ >>
when List.mem s assoc_right_parsed_op_list ->
fun ppf curr next dg k ->
let el =
loop [e1] e2 where rec loop el =
fun
[ <:expr< $lid:s1$ $e1$ $e2$ >> when s1 = s ->
loop [e1 :: el] e2
| e -> List.rev [e :: el] ]
in
fprintf ppf "(@[%s %a@]" s (list expr) (el, ks ")" k)
| <:expr< $e1$ $e2$ >> ->
fun ppf curr next dg k ->
let (f, el) =
loop [e2] e1 where rec loop el =
fun
[ <:expr< $e1$ $e2$ >> -> loop [e2 :: el] e1
| e1 -> (e1, el) ]
in
fprintf ppf "(@[%a@ %a@]" expr (f, nok) (list expr) (el, ks ")" k)
| <:expr< ~ $s$ : ($e$) >> ->
fun ppf curr next dg k ->
fprintf ppf "(~%s@ %a" s expr (e, ks ")" k)
| <:expr< $e1$ .[ $e2$ ] >> ->
fun ppf curr next dg k ->
fprintf ppf "%a.[%a" expr (e1, nok) expr (e2, ks "]" k)
| <:expr< $e1$ .( $e2$ ) >> ->
fun ppf curr next dg k ->
fprintf ppf "%a.(%a" expr (e1, nok) expr (e2, ks ")" k)
| <:expr< $e1$ . $e2$ >> ->
fun ppf curr next dg k ->
fprintf ppf "%a.%a" expr (e1, nok) expr (e2, k)
| <:expr< $int:s$ >> ->
fun ppf curr next dg k -> fprintf ppf "%s%t" (int_repr s) k
| <:expr< $lid:s$ >> | <:expr< $uid:s$ >> ->
fun ppf curr next dg k -> fprintf ppf "%s%t" s k
| <:expr< ` $s$ >> ->
fun ppf curr next dg k -> fprintf ppf "`%s%t" s k
| <:expr< $str:s$ >> ->
fun ppf curr next dg k -> fprintf ppf "\"%s\"%t" s k
| <:expr< $chr:s$ >> ->
fun ppf curr next dg k -> fprintf ppf "'%s'%t" s k
| x ->
fun ppf curr next dg k -> not_impl "expr" x ppf k ]}];
pr_label_decl.pr_levels :=
[{pr_label = "top";
pr_box ppf f x = fprintf ppf "@[%t@]" f;
pr_rules =
extfun Extfun.empty with
[ (loc, f, m, t) ->
fun ppf curr next dg k ->
fprintf ppf "(@[<hv>%s%t@ %a@]" f
(fun ppf -> if m then fprintf ppf "@ mutable" else ())
ctyp (t, ks ")" k) ]}];
pr_let_binding.pr_levels :=
[{pr_label = "top";
pr_box ppf f x = fprintf ppf "@[%t@]" f;
pr_rules =
extfun Extfun.empty with
[ (b, (p, e)) ->
fun ppf curr next dg k ->
let (pl, e) = expr_fun_args e in
match pl with
[ [] ->
fprintf ppf "(@[<b 1>%s%s%a@ %a@]" b
(if b = "" then "" else " ") patt (p, nok)
sequence (e, ks ")" k)
| _ ->
fprintf ppf "(@[<b 1>%s%s(%a)@ %a@]" b
(if b = "" then "" else " ") (list patt) ([p :: pl], nok)
sequence (e, ks ")" k) ] ]}];
pr_match_assoc.pr_levels :=
[{pr_label = "top";
pr_box ppf f x = fprintf ppf "@[%t@]" f;
pr_rules =
extfun Extfun.empty with
[ (p, we, e) ->
fun ppf curr next dg k ->
fprintf ppf "(@[%t@ %a@]"
(fun ppf ->
match we with
[ Some e ->
fprintf ppf "(when@ %a@ %a" patt (p, nok)
expr (e, ks ")" nok)
| None -> patt ppf (p, nok) ])
sequence (e, ks ")" k) ]}];
pr_mod_ident.pr_levels :=
[{pr_label = "top";
pr_box ppf f x = fprintf ppf "@[%t@]" f;
pr_rules =
extfun Extfun.empty with
[ [s] ->
fun ppf curr next dg k ->
fprintf ppf "%s%t" s k
| [s :: sl] ->
fun ppf curr next dg k ->
fprintf ppf "%s.%a" s curr (sl, "", k)
| x ->
fun ppf curr next dg k -> not_impl "mod_ident" x ppf k ]}];
pr_module_binding.pr_levels :=
[{pr_label = "top";
pr_box ppf f x = fprintf ppf "@[%t@]" f;
pr_rules =
extfun Extfun.empty with
[ (b, s, me) ->
fun ppf curr next dg k ->
fprintf ppf "%s@ %s@ %a" b s module_expr (me, k) ]}];
pr_module_expr.pr_levels :=
[{pr_label = "top";
pr_box ppf f x = fprintf ppf "@[%t@]" f;
pr_rules =
extfun Extfun.empty with
[ <:module_expr< functor ($i$ : $mt$) -> $me$ >> ->
fun ppf curr next dg k ->
fprintf ppf "(@[@[@[functor@ %s@]@ %a@]@ %a@]"
i module_type (mt, nok) module_expr (me, ks ")" k)
| <:module_expr< struct $list:sil$ end >> ->
fun ppf curr next dg k ->
fprintf ppf "(@[struct@ @[<hv>%a@]@]" (list str_item)
(sil, ks ")" k)
| <:module_expr< $me1$ $me2$ >> ->
fun ppf curr next dg k ->
fprintf ppf "(@[%a@ %a@]" module_expr (me1, nok)
module_expr (me2, ks ")" k)
| <:module_expr< $uid:s$ >> ->
fun ppf curr next dg k -> fprintf ppf "%s%t" s k
| x ->
fun ppf curr next dg k -> not_impl "module_expr" x ppf k ]}];
pr_module_type.pr_levels :=
[{pr_label = "top";
pr_box ppf f x = fprintf ppf "@[%t@]" f;
pr_rules =
extfun Extfun.empty with
[ <:module_type< functor ($i$ : $mt1$) -> $mt2$ >> ->
fun ppf curr next dg k ->
fprintf ppf "(@[@[@[functor@ %s@]@ %a@]@ %a@]"
i module_type (mt1, nok) module_type (mt2, ks ")" k)
| <:module_type< sig $list:sil$ end >> ->
fun ppf curr next dg k ->
fprintf ppf "(@[sig@ @[<hv>%a@]@]" (list sig_item) (sil, ks ")" k)
| <:module_type< $mt$ with $list:wcl$ >> ->
fun ppf curr next dg k ->
fprintf ppf "(@[with@;<1 2>@[%a@ (%a@]@]" module_type (mt, nok)
(list with_constr) (wcl, ks "))" k)
| <:module_type< $uid:s$ >> ->
fun ppf curr next dg k -> fprintf ppf "%s%t" s k
| x ->
fun ppf curr next dg k -> not_impl "module_type" x ppf k ]}];
pr_patt.pr_levels :=
[{pr_label = "top";
pr_box ppf f x = fprintf ppf "@[%t@]" f;
pr_rules =
extfun Extfun.empty with
[ <:patt< $p1$ | $p2$ >> ->
fun ppf curr next dg k ->
let (f, pl) =
loop [p2] p1 where rec loop pl =
fun
[ <:patt< $p1$ | $p2$ >> -> loop [p2 :: pl] p1
| p1 -> (p1, pl) ]
in
fprintf ppf "(@[or@ %a@ %a@]" patt (f, nok) (list patt)
(pl, ks ")" k)
| <:patt< ($p1$ as $p2$) >> ->
fun ppf curr next dg k ->
fprintf ppf "(@[as@ %a@ %a@]" patt (p1, nok) patt (p2, ks ")" k)
| <:patt< $p1$ .. $p2$ >> ->
fun ppf curr next dg k ->
fprintf ppf "(@[range@ %a@ %a@]" patt (p1, nok) patt (p2, ks ")" k)
| <:patt< [$_$ :: $_$] >> as p ->
fun ppf curr next dg k ->
let (pl, c) =
make_list p where rec make_list p =
match p with
[ <:patt< [$p$ :: $y$] >> ->
let (pl, c) = make_list y in
([p :: pl], c)
| <:patt< [] >> -> ([], None)
| x -> ([], Some p) ]
in
match c with
[ None ->
fprintf ppf "[%a" (list patt) (pl, ks "]" k)
| Some x ->
fprintf ppf "[%a@ %a" (list patt) (pl, ks " ." nok)
patt (x, ks "]" k) ]
| <:patt< $p1$ $p2$ >> ->
fun ppf curr next dg k ->
let pl =
loop [p2] p1 where rec loop pl =
fun
[ <:patt< $p1$ $p2$ >> -> loop [p2 :: pl] p1
| p1 -> [p1 :: pl] ]
in
fprintf ppf "(@[%a@]" (list patt) (pl, ks ")" k)
| <:patt< ($p$ : $t$) >> ->
fun ppf curr next dg k ->
fprintf ppf "(:@ %a@ %a" patt (p, nok) ctyp (t, ks ")" k)
| <:patt< ($list:pl$) >> ->
fun ppf curr next dg k ->
fprintf ppf "(values @[%a@]" (list patt) (pl, ks ")" k)
| <:patt< { $list:fpl$ } >> ->
fun ppf curr next dg k ->
let record_binding ppf ((p1, p2), k) =
fprintf ppf "(@[%a@ %a@]" patt (p1, nok) patt (p2, ks ")" k)
in
fprintf ppf "(@[<hv>{}@ %a@]" (list record_binding) (fpl, ks ")" k)
| <:patt< ? $x$ >> ->
fun ppf curr next dg k -> fprintf ppf "?%s%t" x k
| <:patt< ? ($lid:x$ = $e$) >> ->
fun ppf curr next dg k -> fprintf ppf "(?%s@ %a" x expr (e, ks ")" k)
| <:patt< $p1$ . $p2$ >> ->
fun ppf curr next dg k ->
fprintf ppf "%a.%a" patt (p1, nok) patt (p2, k)
| <:patt< $lid:s$ >> | <:patt< $uid:s$ >> ->
fun ppf curr next dg k -> fprintf ppf "%s%t" s k
| <:patt< $str:s$ >> ->
fun ppf curr next dg k -> fprintf ppf "\"%s\"%t" s k
| <:patt< $chr:s$ >> ->
fun ppf curr next dg k -> fprintf ppf "'%s'%t" s k
| <:patt< $int:s$ >> ->
fun ppf curr next dg k -> fprintf ppf "%s%t" (int_repr s) k
| <:patt< $flo:s$ >> ->
fun ppf curr next dg k -> fprintf ppf "%s%t" s k
| <:patt< _ >> ->
fun ppf curr next dg k -> fprintf ppf "_%t" k
| x ->
fun ppf curr next dg k -> not_impl "patt" x ppf k ]}];
pr_sig_item.pr_levels :=
[{pr_label = "top";
pr_box ppf f x = fprintf ppf "@[%t@]" f;
pr_rules =
extfun Extfun.empty with
[ <:sig_item< type $list:tdl$ >> ->
fun ppf curr next dg k ->
match tdl with
[ [td] -> fprintf ppf "(%a" type_decl (("type", td), ks ")" k)
| tdl ->
fprintf ppf "(@[<hv>type@ %a@]" (listwb "" type_decl)
(tdl, ks ")" k) ]
| <:sig_item< exception $c$ of $list:tl$ >> ->
fun ppf curr next dg k ->
match tl with
[ [] -> fprintf ppf "(@[exception@ %s%t@]" c (ks ")" k)
| tl ->
fprintf ppf "(@[@[exception@ %s@]@ %a@]" c
(list ctyp) (tl, ks ")" k) ]
| <:sig_item< value $i$ : $t$ >> ->
fun ppf curr next dg k ->
fprintf ppf "(@[@[value %s@]@ %a@]" i ctyp (t, ks ")" k)
| <:sig_item< external $i$ : $t$ = $list:pd$ >> ->
fun ppf curr next dg k ->
fprintf ppf "(@[@[external@ %s@]@ %a@ %a@]" i ctyp (t, nok)
(list string) (pd, ks ")" k)
| <:sig_item< module $s$ : $mt$ >> ->
fun ppf curr next dg k ->
fprintf ppf "(@[@[module@ %s@]@ %a@]" s
module_type (mt, ks ")" k)
| <:sig_item< module type $s$ = $mt$ >> ->
fun ppf curr next dg k ->
fprintf ppf "(@[@[moduletype@ %s@]@ %a@]" s
module_type (mt, ks ")" k)
| <:sig_item< declare $list:s$ end >> ->
fun ppf curr next dg k ->
if s = [] then fprintf ppf "; ..."
else fprintf ppf "%a" (list sig_item) (s, k)
| MLast.SgUse _ _ _ ->
fun ppf curr next dg k -> ()
| x ->
fun ppf curr next dg k -> not_impl "sig_item" x ppf k ]}];
pr_str_item.pr_levels :=
[{pr_label = "top";
pr_box ppf f x = fprintf ppf "@[%t@]" f;
pr_rules =
extfun Extfun.empty with
[ <:str_item< open $i$ >> ->
fun ppf curr next dg k ->
fprintf ppf "(open@ %a" mod_ident (i, ks ")" k)
| <:str_item< type $list:tdl$ >> ->
fun ppf curr next dg k ->
match tdl with
[ [td] -> fprintf ppf "(%a" type_decl (("type", td), ks ")" k)
| tdl ->
fprintf ppf "(@[<hv>type@ %a@]" (listwb "" type_decl)
(tdl, ks ")" k) ]
| <:str_item< exception $c$ of $list:tl$ >> ->
fun ppf curr next dg k ->
match tl with
[ [] -> fprintf ppf "(@[exception@ %s%t@]" c (ks ")" k)
| tl ->
fprintf ppf "(@[@[exception@ %s@]@ %a@]" c
(list ctyp) (tl, ks ")" k) ]
| <:str_item< value $opt:rf$ $list:pel$ >> ->
fun ppf curr next dg k ->
let b = if rf then "definerec" else "define" in
match pel with
[ [(p, e)] ->
fprintf ppf "%a" let_binding ((b, (p, e)), k)
| pel ->
fprintf ppf "(@[<hv 1>%s*@ %a@]" b (listwb "" let_binding)
(pel, ks ")" k) ]
| <:str_item< module $s$ = $me$ >> ->
fun ppf curr next dg k ->
fprintf ppf "(%a" module_binding (("module", s, me), ks ")" k)
| <:str_item< module type $s$ = $mt$ >> ->
fun ppf curr next dg k ->
fprintf ppf "(@[@[moduletype@ %s@]@ %a@]" s
module_type (mt, ks ")" k)
| <:str_item< external $i$ : $t$ = $list:pd$ >> ->
fun ppf curr next dg k ->
fprintf ppf "(@[external@ %s@ %a@ %a@]" i ctyp (t, nok)
(list string) (pd, ks ")" k)
| <:str_item< $exp:e$ >> ->
fun ppf curr next dg k ->
fprintf ppf "%a" expr (e, k)
| <:str_item< # $s$ $opt:x$ >> ->
fun ppf curr next dg k ->
match x with
[ Some e -> fprintf ppf "; # (%s %a" s expr (e, ks ")" k)
| None -> fprintf ppf "; # (%s%t" s (ks ")" k) ]
| <:str_item< declare $list:s$ end >> ->
fun ppf curr next dg k ->
if s = [] then fprintf ppf "; ..."
else fprintf ppf "%a" (list str_item) (s, k)
| MLast.StUse _ _ _ ->
fun ppf curr next dg k -> ()
| x ->
fun ppf curr next dg k -> not_impl "str_item" x ppf k ]}];
pr_type_decl.pr_levels :=
[{pr_label = "top";
pr_box ppf f x = fprintf ppf "@[%t@]" f;
pr_rules =
extfun Extfun.empty with
[ (b, ((_, tn), tp, te, cl)) ->
fun ppf curr next dg k ->
fprintf ppf "%t%t@;<1 1>%a"
(fun ppf ->
if b <> "" then fprintf ppf "%s@ " b
else ())
(fun ppf ->
match tp with
[ [] -> fprintf ppf "%s" tn
| tp -> fprintf ppf "(%s%a)" tn type_params (tp, nok) ])
ctyp (te, k) ]}];
pr_type_params.pr_levels :=
[{pr_label = "top";
pr_box ppf f x = fprintf ppf "@[%t@]" f;
pr_rules =
extfun Extfun.empty with
[ [(s, vari) :: tpl] ->
fun ppf curr next dg k ->
fprintf ppf "@ '%s%a" s type_params (tpl, k)
| [] ->
fun ppf curr next dg k -> () ]}];
pr_with_constr.pr_levels :=
[{pr_label = "top";
pr_box ppf f x = fprintf ppf "@[%t@]" f;
pr_rules =
extfun Extfun.empty with
[ MLast.WcTyp _ m tp te ->
fun ppf curr next dg k ->
fprintf ppf "(type@ %t@;<1 1>%a"
(fun ppf ->
match tp with
[ [] -> fprintf ppf "%a" mod_ident (m, nok)
| tp ->
fprintf ppf "(%a@ %a)" mod_ident (m, nok)
type_params (tp, nok) ])
ctyp (te, ks ")" k)
| x ->
fun ppf curr next dg k -> not_impl "with_constr" x ppf k ]}];
(* main *)
value output_string_eval ppf s =
loop 0 where rec loop i =
if i == String.length s then ()
else if i == String.length s - 1 then pp_print_char ppf s.[i]
else
match (s.[i], s.[i + 1]) with
[ ('\\', 'n') -> do { pp_print_char ppf '\n'; loop (i + 2) }
| (c, _) -> do { pp_print_char ppf c; loop (i + 1) } ]
;
value sep = Pcaml.inter_phrases;
value input_source ic len =
let buff = Buffer.create 20 in
try
let rec loop i =
if i >= len then Buffer.contents buff
else do { let c = input_char ic in Buffer.add_char buff c; loop (i + 1) }
in
loop 0
with
[ End_of_file ->
let s = Buffer.contents buff in
if s = "" then
match sep.val with
[ Some s -> s
| None -> "\n" ]
else s ]
;
value copy_source ppf (ic, first, bp, ep) =
match sep.val with
[ Some str ->
if first then ()
else if ep == in_channel_length ic then pp_print_string ppf "\n"
else output_string_eval ppf str
| None ->
do {
seek_in ic bp;
let s = input_source ic (ep - bp) in pp_print_string ppf s
} ]
;
value copy_to_end ppf (ic, first, bp) =
let ilen = in_channel_length ic in
if bp < ilen then copy_source ppf (ic, first, bp, ilen)
else pp_print_string ppf "\n"
;
value apply_printer printer ast =
let ppf = std_formatter in
if Pcaml.input_file.val <> "-" && Pcaml.input_file.val <> "" then do {
let ic = open_in_bin Pcaml.input_file.val in
try
let (first, last_pos) =
List.fold_left
(fun (first, last_pos) (si, (bp, ep)) ->
do {
fprintf ppf "@[%a@]@?" copy_source (ic, first, last_pos.Lexing.pos_cnum, bp.Lexing.pos_cnum);
fprintf ppf "@[%a@]@?" printer (si, nok);
(False, ep)
})
(True, Token.nowhere) ast
in
fprintf ppf "@[%a@]@?" copy_to_end (ic, first, last_pos.Lexing.pos_cnum)
with x ->
do { fprintf ppf "@."; close_in ic; raise x };
close_in ic;
}
else failwith "not implemented"
;
Pcaml.print_interf.val := apply_printer sig_item;
Pcaml.print_implem.val := apply_printer str_item;
Pcaml.add_option "-l" (Arg.Int (fun x -> set_margin x))
"<length> Maximum line length for pretty printing.";
Pcaml.add_option "-sep" (Arg.String (fun x -> sep.val := Some x))
"<string> Use this string between phrases instead of reading source.";

119
camlp4/etc/pr_schp_main.ml
View File

@ -1,119 +0,0 @@
(* camlp4r q_MLast.cmo ./pa_extfun.cmo *)
(* $Id$ *)
open Format;
open Pcaml;
open Parserify;
value nok = Pr_scheme.nok;
value ks = Pr_scheme.ks;
value patt = Pr_scheme.patt;
value expr = Pr_scheme.expr;
value find_pr_level = Pr_scheme.find_pr_level;
value pr_expr = Pr_scheme.pr_expr;
type printer_t 'a = Pr_scheme.printer_t 'a ==
{ pr_fun : mutable string -> Pr_scheme.next 'a;
pr_levels : mutable list (pr_level 'a) }
and pr_level 'a = Pr_scheme.pr_level 'a ==
{ pr_label : string;
pr_box : formatter -> (formatter -> unit) -> 'a -> unit;
pr_rules : mutable Pr_scheme.pr_rule 'a }
;
(* extensions for rebuilding syntax of parsers *)
value parser_cases ppf (spel, k) =
let rec parser_cases ppf (spel, k) =
match spel with
[ [] -> fprintf ppf "[: `HVbox [: b; k :] :]"
| [(sp, epo, e)] -> parser_case ppf (sp, epo, e, k)
| [(sp, epo, e) :: spel] ->
fprintf ppf "%a@ %a" parser_case (sp, epo, e, nok)
parser_cases (spel, k) ]
and parser_case ppf (sp, epo, e, k) =
fprintf ppf "(@[@[(%a)%t@]@ %a@]" stream_patt (sp, nok)
(fun ppf ->
match epo with
[ Some p -> fprintf ppf "@ %a" patt (p, nok)
| None -> () ])
expr (e, ks ")" k)
and stream_patt ppf (sp, k) =
match sp with
[ [] -> k ppf
| [(spc, None)] -> fprintf ppf "%a" stream_patt_comp (spc, k)
| [(spc, Some e)] ->
fprintf ppf "(@[? %a@ %a@]" stream_patt_comp (spc, nok)
expr (e, ks ")" k)
| [(spc, None) :: spcl] ->
fprintf ppf "%a@ %a" stream_patt_comp (spc, nok) stream_patt (spcl, k)
| [(spc, Some e) :: spcl] ->
fprintf ppf "(@[? %a@ %a@]@ %a" stream_patt_comp (spc, nok)
expr (e, ks ")" nok) stream_patt (spcl, k) ]
and stream_patt_comp ppf (spc, k) =
match spc with
[ SPCterm (p, w) ->
match w with
[ Some e ->
fprintf ppf "(` %a@ %a" patt (p, nok) expr (e, ks ")" k)
| None -> fprintf ppf "(` %a" patt (p, ks ")" k) ]
| SPCnterm p e ->
fprintf ppf "(@[%a %a@]" patt (p, nok) expr (e, ks ")" k)
| SPCsterm p -> fprintf ppf "%a" patt (p, k) ]
in
parser_cases ppf (spel, k)
;
value parser_body ppf (e, k) =
let (bp, e) =
match e with
[ <:expr< let $bp$ = Stream.count strm__ in $e$ >> -> (Some bp, e)
| e -> (None, e) ]
in
match parser_of_expr e with
[ [] ->
fprintf ppf "(parser%t%t"
(fun ppf ->
match bp with
[ Some p -> fprintf ppf "@ %a" patt (p, nok)
| _ -> ()])
(ks ")" k)
| spel ->
fprintf ppf "(@[<v>@[parser%t@]@ @[<v 0>%a@]@]"
(fun ppf ->
match bp with
[ Some p -> fprintf ppf "@ %a" patt (p, nok)
| _ -> ()])
parser_cases (spel, ks ")" k) ]
;
value pmatch ppf (e, k) =
let (me, e) =
match e with
[ <:expr< let (strm__ : Stream.t _) = $me$ in $e$ >> -> (me, e)
| _ -> failwith "Pr_schp_main.pmatch" ]
in
let (bp, e) =
match e with
[ <:expr< let $bp$ = Stream.count strm__ in $e$ >> -> (Some bp, e)
| e -> (None, e) ]
in
let spel = parser_of_expr e in
fprintf ppf "(@[@[match_with_parser@ %a@]%t@ @[<v 0>%a@]@]" expr (me, nok)
(fun ppf ->
match bp with
[ Some p -> fprintf ppf "@ %a" patt (p, nok)
| _ -> () ])
parser_cases (spel, ks ")" k)
;
pr_expr_fun_args.val :=
extfun pr_expr_fun_args.val with
[ <:expr< fun [(strm__ : $_$) -> $_$] >> as ge -> ([], ge) ];
let lev = find_pr_level "top" pr_expr.pr_levels in
lev.pr_rules :=
extfun lev.pr_rules with
[ <:expr< fun (strm__ : $_$) -> $x$ >> ->
fun ppf curr next dg k -> fprintf ppf "%a" parser_body (x, k)
| <:expr< let (strm__ : Stream.t _) = $_$ in $_$ >> as e ->
fun ppf curr next dg k -> fprintf ppf "%a" pmatch (e, k) ];

18
camlp4/lib/Makefile
View File

@ -9,7 +9,10 @@ SHELL=/bin/sh
TARGET=gramlib.cma
all: $(TARGET)
opt: $(TARGET:.cma=.cmxa)
opt: opt$(PROFILING)
optnoprof: $(TARGET:.cma=.cmxa)
optprof: optnoprof $(TARGET:.cma=.p.cmxa)
$(TARGET): $(OBJS)
$(OCAMLC) $(OBJS) -a -o $(TARGET)
@ -17,6 +20,9 @@ $(TARGET): $(OBJS)
$(TARGET:.cma=.cmxa): $(OBJS:.cmo=.cmx)
$(OCAMLOPT) $(OBJS:.cmo=.cmx) -a -o $(TARGET:.cma=.cmxa)
$(TARGET:.cma=.p.cmxa): $(OBJS:.cmo=.p.cmx)
$(OCAMLOPT) $(OBJS:.cmo=.p.cmx) -a -o $(TARGET:.cma=.p.cmxa)
clean::
rm -f *.cm[ioax] *.cmxa *.pp[io] *.$(O) *.$(A) *.bak .*.bak $(TARGET)
@ -39,10 +45,14 @@ install:
-$(MKDIR) "$(LIBDIR)/camlp4"
cp $(TARGET) *.mli "$(LIBDIR)/camlp4/."
cp *.cmi "$(LIBDIR)/camlp4/."
if test -f $(TARGET:.cma=.cmxa); then $(MAKE) installopt LIBDIR="$(LIBDIR)"; fi
test -f $(TARGET:.cma=.cmxa) && $(MAKE) installopt LIBDIR="$(LIBDIR)" || true
installopt:
cp $(TARGET:.cma=.cmxa) *.cmx "$(LIBDIR)/camlp4/."
TARG=`echo "$(TARGET)" | sed -e "s/\.cma\$$/.$(A)/g"` && tar cf - $$TARG | (cd "$(LIBDIR)/camlp4/." && tar xf -)
for f in $(TARGET:.cma=.cmxa) $(TARGET:.cma=.p.cmxa) ; do \
test -f $$f && cp $$f "$(LIBDIR)/camlp4/." || true ; \
done
# Special treatment for this one: some versions of make don't like $(A) in $(TARGET:.cma=.$(A))
target="`echo $(TARGET) | sed -e 's/\.cma$$/.$(A)/'`" ; \
test -f $$target && cp $$target "$(LIBDIR)/camlp4/." || true
include .depend

9
camlp4/lib/plexer.ml
View File

@ -398,6 +398,13 @@ value next_token_fun dfa ssd find_kwd fname lnum bolpos glexr =
| [: :] -> store len '\\' ];
s :] ->
quotation bp len s
| [: `'\010'; s :] -> do {bolpos.val := bp+1; incr lnum; quotation bp (store len '\010') s}
| [: `'\013'; s :] ->
let bol =
match Stream.peek s with
[ Some '\010' -> do { Stream.junk s; bp+2 }
| _ -> bp+1 ] in
do { bolpos.val := bol; incr lnum; quotation bp (store len '\013') s}
| [: `c; s :] -> quotation bp (store len c) s
| [: :] ep -> err (mkloc (bp, ep)) "quotation not terminated" ]
and maybe_nested_quotation bp len =
@ -431,7 +438,7 @@ value next_token_fun dfa ssd find_kwd fname lnum bolpos glexr =
[ Some '\010' -> do { Stream.junk s; ep+1 }
| _ -> ep ] in
do { bolpos.val := ep; incr lnum; comment bp s }
| [: `c; s :] -> comment bp s
| [: `c; s :] -> comment bp s
| [: :] ep -> err (mkloc (bp, ep)) "comment not terminated" ]
and quote_in_comment bp =
parser

34
camlp4/lib/token.ml
View File

@ -219,22 +219,26 @@ value eval_string (bp, ep) s =
let (len, i) =
if s.[i] = '\\' then
let i = i + 1 in
if i = String.length s then failwith "invalid string token"
else if s.[i] = '"' then (store len '"', i + 1)
else
match s.[i] with
[ '\010' -> (len, skip_indent s (i + 1))
| '\013' -> (len, skip_indent s (skip_opt_linefeed s (i + 1)))
| c ->
try
let (c, i) = backslash s i in
(store len c, i)
with
if i = String.length s then failwith "invalid string token" else
if s.[i] = '"' then (store len '"', i + 1) else
match s.[i] with
[ '\010' -> (len, skip_indent s (i + 1))
| '\013' -> (len, skip_indent s (skip_opt_linefeed s (i + 1)))
| c ->
try
let (c, i) = backslash s i in
(store len c, i)
with
[ Not_found -> do {
Printf.eprintf
"Warning: char %d, Invalid backslash escape in string\n%!"
(bp.Lexing.pos_cnum + i + 1);
(store (store len '\\') c, i + 1) } ] ]
let txt = "Invalid backslash escape in string" in
let pos = bp.Lexing.pos_cnum - bp.Lexing.pos_bol + i in
if bp.Lexing.pos_fname = "" then
Printf.eprintf "Warning: line %d, chars %d-%d: %s\n"
bp.Lexing.pos_lnum pos (pos + 1) txt
else
Printf.eprintf "Warning: File \"%s\", line %d, chars %d-%d: %s\n"
bp.Lexing.pos_fname bp.Lexing.pos_lnum pos (pos + 1) txt;
(store (store len '\\') c, i + 1) } ] ]
else (store len s.[i], i + 1)
in
loop len i

2
camlp4/meta/.depend
View File

@ -2,8 +2,6 @@ pa_extend.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi ../camlp4/reloc.cmi
pa_extend.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx ../camlp4/reloc.cmx
pa_extend_m.cmo: pa_extend.cmo
pa_extend_m.cmx: pa_extend.cmx
pa_ifdef.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi
pa_ifdef.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx
pa_macro.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi
pa_macro.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx
pa_r.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi

5
camlp4/meta/Makefile
View File

@ -49,7 +49,10 @@ install:
cp camlp4r$(EXE) "$(BINDIR)/."
if test -f camlp4r.opt; then \
cp camlp4r.opt "$(BINDIR)/camlp4r.opt$(EXE)" ;\
cp $(OBJSX) $(OBJSX:.cmx=.$(O)) "$(LIBDIR)/camlp4/."; \
cp $(OBJSX) "$(LIBDIR)/camlp4/."; \
for file in $(OBJSX); do \
cp "`echo $$file | sed -e 's/\.cmx$$/.$(O)/'`" "$(LIBDIR)/camlp4/."; \
done ; \
fi
include .depend

12
camlp4/meta/mk_q_MLast.sh
View File

@ -1,12 +0,0 @@
#!/bin/sh
# $Id$
IFILE=pa_r.ml
OFILE=q_MLast.ml
(
sed -e '/^EXTEND$/,$d' $OFILE
echo EXTEND
../../boot/ocamlrun ./camlp4r -I . -I ../etc q_MLast.cmo pa_extend.cmo pr_r.cmo pr_extend.cmo -cip -quotify $IFILE | sed -e '1,/^EXTEND$/d' -e '/^END;$/,$d'
echo ' (* Antiquotations for local entries *)'
sed -e '1,/Antiquotations for local entries/d' $OFILE
)

85
camlp4/meta/pa_ifdef.ml
View File

@ -1,85 +0,0 @@
(* camlp4r pa_extend.cmo q_MLast.cmo *)
(* $Id$ *)
type item_or_def 'a =
[ SdStr of 'a | SdDef of string | SdUnd of string | SdNop ]
;
value list_remove x l =
List.fold_right (fun e l -> if e = x then l else [e :: l]) l []
;
value defined = ref ["OCAML_305"; "CAMLP4_300"; "NEWSEQ"];
value define x = defined.val := [x :: defined.val];
value undef x = defined.val := list_remove x defined.val;
EXTEND
GLOBAL: Pcaml.expr Pcaml.str_item Pcaml.sig_item;
Pcaml.expr: LEVEL "top"
[ [ "ifdef"; c = UIDENT; "then"; e1 = Pcaml.expr; "else";
e2 = Pcaml.expr ->
if List.mem c defined.val then e1 else e2
| "ifndef"; c = UIDENT; "then"; e1 = Pcaml.expr; "else";
e2 = Pcaml.expr ->
if List.mem c defined.val then e2 else e1 ] ]
;
Pcaml.str_item: FIRST
[ [ x = def_undef_str ->
match x with
[ SdStr si -> si
| SdDef x -> do { define x; <:str_item< declare end >> }
| SdUnd x -> do { undef x; <:str_item< declare end >> }
| SdNop -> <:str_item< declare end >> ] ] ]
;
def_undef_str:
[ [ "ifdef"; c = UIDENT; "then"; e1 = str_item_def_undef;
"else"; e2 = str_item_def_undef ->
if List.mem c defined.val then e1 else e2
| "ifdef"; c = UIDENT; "then"; e1 = str_item_def_undef ->
if List.mem c defined.val then e1 else SdNop
| "ifndef"; c = UIDENT; "then"; e1 = str_item_def_undef;
"else"; e2 = str_item_def_undef ->
if List.mem c defined.val then e2 else e1
| "ifndef"; c = UIDENT; "then"; e1 = str_item_def_undef ->
if List.mem c defined.val then SdNop else e1
| "define"; c = UIDENT -> SdDef c
| "undef"; c = UIDENT -> SdUnd c ] ]
;
str_item_def_undef:
[ [ d = def_undef_str -> d
| si = Pcaml.str_item -> SdStr si ] ]
;
Pcaml.sig_item: FIRST
[ [ x = def_undef_sig ->
match x with
[ SdStr si -> si
| SdDef x -> do { define x; <:sig_item< declare end >> }
| SdUnd x -> do { undef x; <:sig_item< declare end >> }
| SdNop -> <:sig_item< declare end >> ] ] ]
;
def_undef_sig:
[ [ "ifdef"; c = UIDENT; "then"; e1 = sig_item_def_undef;
"else"; e2 = sig_item_def_undef ->
if List.mem c defined.val then e1 else e2
| "ifdef"; c = UIDENT; "then"; e1 = sig_item_def_undef ->
if List.mem c defined.val then e1 else SdNop
| "ifndef"; c = UIDENT; "then"; e1 = sig_item_def_undef;
"else"; e2 = sig_item_def_undef ->
if List.mem c defined.val then e2 else e1
| "ifndef"; c = UIDENT; "then"; e1 = sig_item_def_undef ->
if List.mem c defined.val then SdNop else e1
| "define"; c = UIDENT -> SdDef c
| "undef"; c = UIDENT -> SdUnd c ] ]
;
sig_item_def_undef:
[ [ d = def_undef_sig -> d
| si = Pcaml.sig_item -> SdStr si ] ]
;
END;
Pcaml.add_option "-D" (Arg.String define)
"<string> Define for ifdef instruction."
;
Pcaml.add_option "-U" (Arg.String undef)
"<string> Undefine for ifdef instruction."
;

151
camlp4/meta/pa_macro.ml
View File

@ -9,33 +9,43 @@ Added statements:
DEFINE <uident>
DEFINE <uident> = <expression>
DEFINE <uident> (<parameters>) = <expression>
IFDEF <uident> THEN <structure_items> END
IFDEF <uident> THEN <structure_items> ELSE <structure_items> END
IFNDEF <uident> THEN <structure_items> END
IFNDEF <uident> THEN <structure_items> ELSE <structure_items> END
IFDEF <uident> THEN <structure_items> (END | ENDIF)
IFDEF <uident> THEN <structure_items> ELSE <structure_items> (END | ENDIF)
IFNDEF <uident> THEN <structure_items> (END | ENDIF)
IFNDEF <uident> THEN <structure_items> ELSE <structure_items> (END | ENDIF)
INCLUDE <string>
In expressions:
IFDEF <uident> THEN <expression> ELSE <expression> END
IFNDEF <uident> THEN <expression> ELSE <expression> END
IFDEF <uident> THEN <expression> ELSE <expression> (END | ENDIF)
IFNDEF <uident> THEN <expression> ELSE <expression> (END | ENDIF)
__FILE__
__LOCATION__
In patterns:
IFDEF <uident> THEN <pattern> ELSE <pattern> END
IFNDEF <uident> THEN <pattern> ELSE <pattern> END
IFDEF <uident> THEN <pattern> ELSE <pattern> (END | ENDIF)
IFNDEF <uident> THEN <pattern> ELSE <pattern> (END | ENDIF)
As Camlp4 options:
-D<uident>
-U<uident>
-D<uident> define <uident>
-U<uident> undefine it
-I<dir> add <dir> to the search path for INCLUDE'd files
After having used a DEFINE <uident> followed by "= <expression>", you
can use it in expressions *and* in patterns. If the expression defining
the macro cannot be used as a pattern, there is an error message if
it is used in a pattern.
The toplevel statement INCLUDE <string> can be used to include a
file containing macro definitions; note that files included in such
a way can not have any non-macro toplevel items. The included files
are looked up in directories passed in via the -I option, falling
back to the current directory.
The expression __FILE__ returns the current compiled file name.
The expression __LOCATION__ returns the current location of itself.
@ -50,7 +60,8 @@ type item_or_def 'a =
[ SdStr of 'a
| SdDef of string and option (list string * MLast.expr)
| SdUnd of string
| SdNop ]
| SdITE of string and list (item_or_def 'a) and list (item_or_def 'a)
| SdInc of string ]
;
value rec list_remove x =
@ -70,7 +81,7 @@ value loc =
(nowhere, nowhere);
value subst mloc env =
loop where rec loop =
let rec loop =
fun
[ <:expr< let $opt:rf$ $list:pel$ in $e$ >> ->
let pel = List.map (fun (p, e) -> (p, loop e)) pel in
@ -78,14 +89,29 @@ value subst mloc env =
| <:expr< if $e1$ then $e2$ else $e3$ >> ->
<:expr< if $loop e1$ then $loop e2$ else $loop e3$ >>
| <:expr< $e1$ $e2$ >> -> <:expr< $loop e1$ $loop e2$ >>
| <:expr< fun $args$ -> $e$ >> -> <:expr< fun $args$ -> $loop e$ >>
| <:expr< fun [ $list: peoel$ ] >> -> <:expr< fun [ $list: (List.map loop_peoel peoel)$ ] >>
| <:expr< $lid:x$ >> | <:expr< $uid:x$ >> as e ->
try <:expr< $anti:List.assoc x env$ >> with
[ Not_found -> e ]
| <:expr< ($list:x$) >> -> <:expr< ($list:List.map loop x$) >>
| <:expr< do {$list:x$} >> -> <:expr< do {$list:List.map loop x$} >>
| <:expr< { $list:pel$ } >> ->
let pel = List.map (fun (p, e) -> (p, loop e)) pel in
<:expr< { $list:pel$ } >>
| <:expr< match $e$ with [ $list:peoel$ ] >> ->
<:expr< match $loop e$ with [ $list: (List.map loop_peoel peoel)$ ] >>
| <:expr< try $e$ with [ $list:pel$ ] >> ->
let loop' = fun
[ (p, Some e1, e2) -> (p, Some (loop e1), loop e2)
| (p, None, e2) -> (p, None, loop e2) ] in
<:expr< try $loop e$ with [ $list: (List.map loop' pel)$ ] >>
| e -> e ]
and loop_peoel =
fun
[ (p, Some e1, e2) -> (p, Some (loop e1), loop e2)
| (p, None, e2) -> (p, None, loop e2) ]
in loop
;
value substp mloc env =
@ -99,6 +125,7 @@ value substp mloc env =
try <:patt< $anti:List.assoc x env$ >> with
[ Not_found -> <:patt< $uid:x$ >> ]
| <:expr< $int:x$ >> -> <:patt< $int:x$ >>
| <:expr< $str:s$ >> -> <:patt< $str:s$ >>
| <:expr< ($list:x$) >> -> <:patt< ($list:List.map loop x$) >>
| <:expr< { $list:pel$ } >> ->
let ppl = List.map (fun (p, e) -> (p, loop e)) pel in
@ -188,34 +215,87 @@ value undef x =
[ Not_found -> () ]
;
(* This is a list of directories to search for INCLUDE statements. *)
value include_dirs = ref []
;
(* Add something to the above, make sure it ends with a slash. *)
value add_include_dir str =
if str <> "" then
let str =
if String.get str ((String.length str)-1) = '/'
then str else str ^ "/"
in include_dirs.val := include_dirs.val @ [str]
else ()
;
value smlist = Grammar.Entry.create Pcaml.gram "smlist"
;
value parse_include_file =
let dir_ok file dir = Sys.file_exists (dir ^ file) in
fun file ->
let file =
try (List.find (dir_ok file) (include_dirs.val @ ["./"])) ^ file
with [ Not_found -> file ]
in
let st = Stream.of_channel (open_in file) in
let old_input = Pcaml.input_file.val in
do {
Pcaml.input_file.val := file;
let items = Grammar.Entry.parse smlist st in
do { Pcaml.input_file.val := old_input; items } }
;
value rec execute_macro = fun
[ SdStr i -> [i]
| SdDef x eo -> do { define eo x; [] }
| SdUnd x -> do { undef x; [] }
| SdITE i l1 l2 ->
execute_macro_list (if is_defined i then l1 else l2)
| SdInc f -> execute_macro_list (parse_include_file f) ]
and execute_macro_list = fun
[ [] -> []
| [hd::tl] -> (* The evaluation order is important here *)
let il1 = execute_macro hd in
let il2 = execute_macro_list tl in
il1 @ il2 ]
;
EXTEND
GLOBAL: expr patt str_item sig_item;
GLOBAL: expr patt str_item sig_item smlist;
str_item: FIRST
[ [ x = macro_def ->
match x with
[ SdStr [si] -> si
| SdStr sil -> <:str_item< declare $list:sil$ end >>
| SdDef x eo -> do { define eo x; <:str_item< declare end >> }
| SdUnd x -> do { undef x; <:str_item< declare end >> }
| SdNop -> <:str_item< declare end >> ] ] ]
match execute_macro x with
[ [si] -> si
| sil -> <:str_item< declare $list:sil$ end >> ] ] ]
;
macro_def:
[ [ "DEFINE"; i = uident; def = opt_macro_value -> SdDef i def
| "UNDEF"; i = uident -> SdUnd i
| "IFDEF"; i = uident; "THEN"; d = str_item_or_macro; "END" ->
if is_defined i then d else SdNop
| "IFDEF"; i = uident; "THEN"; d1 = str_item_or_macro; "ELSE";
d2 = str_item_or_macro; "END" ->
if is_defined i then d1 else d2
| "IFNDEF"; i = uident; "THEN"; d = str_item_or_macro; "END" ->
if is_defined i then SdNop else d
| "IFNDEF"; i = uident; "THEN"; d1 = str_item_or_macro; "ELSE";
d2 = str_item_or_macro; "END" ->
if is_defined i then d2 else d1 ] ]
| "IFDEF"; i = uident; "THEN"; dl = smlist; _ = endif ->
SdITE i dl []
| "IFDEF"; i = uident; "THEN"; dl1 = smlist; "ELSE";
dl2 = smlist; _ = endif ->
SdITE i dl1 dl2
| "IFNDEF"; i = uident; "THEN"; dl = smlist; _ = endif ->
SdITE i [] dl
| "IFNDEF"; i = uident; "THEN"; dl1 = smlist; "ELSE";
dl2 = smlist; _ = endif ->
SdITE i dl2 dl1
| "INCLUDE"; fname = STRING -> SdInc fname ] ]
;
smlist:
[ [ sml = LIST1 str_item_or_macro -> sml ] ]
;
endif:
[ [ "END" -> ()
| "ENDIF" -> () ] ]
;
str_item_or_macro:
[ [ d = macro_def -> d
| si = LIST1 str_item -> SdStr si ] ]
| si = str_item -> SdStr si ] ]
;
opt_macro_value:
[ [ "("; pl = LIST1 LIDENT SEP ","; ")"; "="; e = expr -> Some (pl, e)
@ -223,9 +303,9 @@ EXTEND
| -> None ] ]
;
expr: LEVEL "top"
[ [ "IFDEF"; i = uident; "THEN"; e1 = expr; "ELSE"; e2 = expr; "END" ->
[ [ "IFDEF"; i = uident; "THEN"; e1 = expr; "ELSE"; e2 = expr; _ = endif ->
if is_defined i then e1 else e2
| "IFNDEF"; i = uident; "THEN"; e1 = expr; "ELSE"; e2 = expr; "END" ->
| "IFNDEF"; i = uident; "THEN"; e1 = expr; "ELSE"; e2 = expr; _ = endif ->
if is_defined i then e2 else e1 ] ]
;
expr: LEVEL "simple"
@ -236,9 +316,9 @@ EXTEND
<:expr< ($int:bp$, $int:ep$) >> ] ]
;
patt:
[ [ "IFDEF"; i = uident; "THEN"; p1 = patt; "ELSE"; p2 = patt; "END" ->
[ [ "IFDEF"; i = uident; "THEN"; p1 = patt; "ELSE"; p2 = patt; _ = endif ->
if is_defined i then p1 else p2
| "IFNDEF"; i = uident; "THEN"; p1 = patt; "ELSE"; p2 = patt; "END" ->
| "IFNDEF"; i = uident; "THEN"; p1 = patt; "ELSE"; p2 = patt; _ = endif ->
if is_defined i then p2 else p1 ] ]
;
uident:
@ -252,3 +332,6 @@ Pcaml.add_option "-D" (Arg.String (define None))
Pcaml.add_option "-U" (Arg.String undef)
"<string> Undefine for IFDEF instruction."
;
Pcaml.add_option "-I" (Arg.String add_include_dir)
"<string> Add a directory to INCLUDE search path."
;

4
camlp4/ocaml_src/camlp4/.depend
View File

@ -13,10 +13,6 @@ ast2pt.cmx: $(OTOP)/parsing/asttypes.cmi $(OTOP)/parsing/location.cmx \
pcaml.cmx ast2pt.cmi
pcaml.cmo: mLast.cmi quotation.cmi reloc.cmi spretty.cmi pcaml.cmi
pcaml.cmx: mLast.cmi quotation.cmx reloc.cmx spretty.cmx pcaml.cmi
crc.cmo: $(OTOP)/otherlibs/dynlink/dynlink.cmi
crc.cmx: $(OTOP)/otherlibs/dynlink/dynlink.cmx
pcaml.cmo: ast2pt.cmi mLast.cmi quotation.cmi reloc.cmi spretty.cmi pcaml.cmi
pcaml.cmx: ast2pt.cmx mLast.cmi quotation.cmx reloc.cmx spretty.cmx pcaml.cmi
quotation.cmo: mLast.cmi quotation.cmi
quotation.cmx: mLast.cmi quotation.cmi
reloc.cmo: mLast.cmi reloc.cmi

31
camlp4/ocaml_src/camlp4/Makefile
View File

@ -18,23 +18,35 @@ CAMLP4=camlp4$(EXE)
CAMLP4OPT=phony
all: $(CAMLP4)
opt: $(OBJS:.cma=.cmxa)
opt: opt$(PROFILING)
optnoprof: $(OBJS:.cma=.cmxa)
optprof: optnoprof $(OBJS:.cma=.p.cmxa)
optp4: $(CAMLP4OPT)
$(CAMLP4): $(OBJS) ../odyl/odyl.cmo
$(OCAMLC) -g $(OBJS) $(CAMLP4M) ../odyl/odyl.cmo -linkall -o $(CAMLP4)
$(OCAMLC) -linkall -o $@ $(OBJS) $(CAMLP4M) ../odyl/odyl.cmo
$(CAMLP4OPT): $(OBJS:.cma=.cmxa) ../odyl/odyl.cmx
$(OCAMLOPT) $(OBJS:.cma=.cmxa) $(CAMLP4M) ../odyl/odyl.cmx -linkall -o $(CAMLP4OPT)
$(OCAMLOPT) -o $@ $(OBJS:.cma=.cmxa) $(CAMLP4M) ../odyl/odyl.cmx
$(OTOP)/utils/config.cmx: $(OTOP)/utils/config.ml
$(OCAMLOPT) -c $(OTOP)/utils/config.ml
$(OCAMLOPT) -I $(OTOP)/utils -c $(OTOP)/utils/config.ml
$(OTOP)/utils/config.p.cmx: $(OTOP)/utils/config.ml
$(OCAMLOPT) -I $(OTOP)/utils -p -c -o $@ $(OTOP)/utils/config.ml
camlp4.cma: $(CAMLP4_OBJS)
$(OCAMLC) $(LINKFLAGS) $(CAMLP4_OBJS) -a -o camlp4.cma
$(OCAMLC) $(LINKFLAGS) -a -o $@ $(CAMLP4_OBJS)
camlp4.cmxa: $(CAMLP4_XOBJS)
$(OCAMLOPT) $(LINKFLAGS) $(CAMLP4_XOBJS) -a -o camlp4.cmxa
$(OCAMLOPT) $(LINKFLAGS) -a -o $@ $(CAMLP4_XOBJS)
camlp4.p.cmxa: $(CAMLP4_XOBJS:.cmx=.p.cmx)
$(OCAMLOPT) $(LINKFLAGS) -a -o $@ $(CAMLP4_XOBJS:.cmx=.p.cmx)
clean::
rm -f *.cm* *.pp[io] *.$(O) *.$(A) *.bak .*.bak *.out *.opt
@ -63,9 +75,8 @@ install:
cp mLast.mli quotation.mli ast2pt.mli pcaml.mli spretty.mli "$(LIBDIR)/camlp4/."
cp mLast.cmi quotation.cmi ast2pt.cmi pcaml.cmi spretty.cmi "$(LIBDIR)/camlp4/."
cp camlp4.cma $(LIBDIR)/camlp4/.
if [ -f camlp4.cmxa ]; \
then cp camlp4.cmxa camlp4.$(A) $(LIBDIR)/camlp4/.; \
else : ; \
fi
for f in camlp4.$(A) camlp4.p.$(A) camlp4.cmxa camlp4.p.cmxa; do \
test -f $$f && cp $$f "$(LIBDIR)/camlp4/." || true; \
done
include .depend

5
camlp4/ocaml_src/camlp4/argl.ml
View File

@ -398,7 +398,10 @@ let go () =
Stdpp.Exc_located ((bp, ep), exc) -> print_location (bp, ep); exc
| _ -> exc
in
report_error exc; Format.close_box (); Format.print_newline (); exit 2
report_error exc;
Format.close_box ();
Format.print_newline ();
raise exc
;;
Odyl_main.name := "camlp4";;

36
camlp4/ocaml_src/camlp4/pcaml.ml
View File

@ -206,6 +206,19 @@ let handle_patt_locate loc x = handle_locate loc patt_eoi patt_anti x;;
let expr_reloc = Reloc.expr;;
let patt_reloc = Reloc.patt;;
let ctyp_reloc = Reloc.ctyp;;
let row_field_reloc = Reloc.row_field;;
let class_infos_reloc = Reloc.class_infos;;
let module_type_reloc = Reloc.module_type;;
let sig_item_reloc = Reloc.sig_item;;
let with_constr_reloc = Reloc.with_constr;;
let module_expr_reloc = Reloc.module_expr;;
let str_item_reloc = Reloc.str_item;;
let class_type_reloc = Reloc.class_type;;
let class_sig_item_reloc = Reloc.class_sig_item;;
let class_expr_reloc = Reloc.class_expr;;
let class_str_item_reloc = Reloc.class_str_item;;
let rename_id = ref (fun x -> x);;
let find_line (bp, ep) str =
@ -346,7 +359,6 @@ let report_error exn =
;;
let no_constructors_arity = ref false;;
(*value no_assert = ref False;*)
let arg_spec_list_ref = ref [];;
let arg_spec_list () = !arg_spec_list_ref;;
@ -373,37 +385,37 @@ and kont = pretty Stream.t
;;
let pr_str_item =
{pr_fun = (fun _ -> raise (Match_failure ("", 397, 30))); pr_levels = []}
{pr_fun = (fun _ -> raise (Match_failure ("", 409, 30))); pr_levels = []}
;;
let pr_sig_item =
{pr_fun = (fun _ -> raise (Match_failure ("", 398, 30))); pr_levels = []}
{pr_fun = (fun _ -> raise (Match_failure ("", 410, 30))); pr_levels = []}
;;
let pr_module_type =
{pr_fun = (fun _ -> raise (Match_failure ("", 399, 33))); pr_levels = []}
{pr_fun = (fun _ -> raise (Match_failure ("", 411, 33))); pr_levels = []}
;;
let pr_module_expr =
{pr_fun = (fun _ -> raise (Match_failure ("", 400, 33))); pr_levels = []}
{pr_fun = (fun _ -> raise (Match_failure ("", 412, 33))); pr_levels = []}
;;
let pr_expr =
{pr_fun = (fun _ -> raise (Match_failure ("", 401, 26))); pr_levels = []}
{pr_fun = (fun _ -> raise (Match_failure ("", 413, 26))); pr_levels = []}
;;
let pr_patt =
{pr_fun = (fun _ -> raise (Match_failure ("", 402, 26))); pr_levels = []}
{pr_fun = (fun _ -> raise (Match_failure ("", 414, 26))); pr_levels = []}
;;
let pr_ctyp =
{pr_fun = (fun _ -> raise (Match_failure ("", 403, 26))); pr_levels = []}
{pr_fun = (fun _ -> raise (Match_failure ("", 415, 26))); pr_levels = []}
;;
let pr_class_sig_item =
{pr_fun = (fun _ -> raise (Match_failure ("", 404, 36))); pr_levels = []}
{pr_fun = (fun _ -> raise (Match_failure ("", 416, 36))); pr_levels = []}
;;
let pr_class_str_item =
{pr_fun = (fun _ -> raise (Match_failure ("", 405, 36))); pr_levels = []}
{pr_fun = (fun _ -> raise (Match_failure ("", 417, 36))); pr_levels = []}
;;
let pr_class_type =
{pr_fun = (fun _ -> raise (Match_failure ("", 406, 32))); pr_levels = []}
{pr_fun = (fun _ -> raise (Match_failure ("", 418, 32))); pr_levels = []}
;;
let pr_class_expr =
{pr_fun = (fun _ -> raise (Match_failure ("", 407, 32))); pr_levels = []}
{pr_fun = (fun _ -> raise (Match_failure ("", 419, 32))); pr_levels = []}
;;
let pr_expr_fun_args = ref Extfun.empty;;

38
camlp4/ocaml_src/camlp4/pcaml.mli
View File

@ -76,9 +76,6 @@ val add_option : string -> Arg.spec -> string -> unit;;
(** Add an option to the command line options. *)
val no_constructors_arity : bool ref;;
(** [True]: dont generate constructor arity. *)
(*value no_assert : ref bool;
(** [True]: dont generate assertion checks. *)
*)
val sync : (char Stream.t -> unit) ref;;
@ -88,11 +85,46 @@ val handle_expr_locate : MLast.loc -> Lexing.position * string -> MLast.expr;;
val handle_patt_quotation : MLast.loc -> string * string -> MLast.patt;;
val handle_patt_locate : MLast.loc -> Lexing.position * string -> MLast.patt;;
(** Relocation functions for abstract syntax trees *)
val expr_reloc :
(MLast.loc -> MLast.loc) -> Lexing.position -> MLast.expr -> MLast.expr;;
val patt_reloc :
(MLast.loc -> MLast.loc) -> Lexing.position -> MLast.patt -> MLast.patt;;
val ctyp_reloc : (MLast.loc -> MLast.loc) -> 'a -> MLast.ctyp -> MLast.ctyp;;
val row_field_reloc :
(MLast.loc -> MLast.loc) -> 'a -> MLast.row_field -> MLast.row_field;;
val class_infos_reloc :
((MLast.loc -> MLast.loc) -> 'a -> 'b -> 'c) -> (MLast.loc -> MLast.loc) ->
'a -> 'b MLast.class_infos -> 'c MLast.class_infos;;
val module_type_reloc :
(MLast.loc -> MLast.loc) -> Lexing.position -> MLast.module_type ->
MLast.module_type;;
val sig_item_reloc :
(MLast.loc -> MLast.loc) -> Lexing.position -> MLast.sig_item ->
MLast.sig_item;;
val with_constr_reloc :
(MLast.loc -> MLast.loc) -> Lexing.position -> MLast.with_constr ->
MLast.with_constr;;
val module_expr_reloc :
(MLast.loc -> MLast.loc) -> Lexing.position -> MLast.module_expr ->
MLast.module_expr;;
val str_item_reloc :
(MLast.loc -> MLast.loc) -> Lexing.position -> MLast.str_item ->
MLast.str_item;;
val class_type_reloc :
(MLast.loc -> MLast.loc) -> Lexing.position -> MLast.class_type ->
MLast.class_type;;
val class_sig_item_reloc :
(MLast.loc -> MLast.loc) -> Lexing.position -> MLast.class_sig_item ->
MLast.class_sig_item;;
val class_expr_reloc :
(MLast.loc -> MLast.loc) -> Lexing.position -> MLast.class_expr ->
MLast.class_expr;;
val class_str_item_reloc :
(MLast.loc -> MLast.loc) -> Lexing.position -> MLast.class_str_item ->
MLast.class_str_item;;
(** To possibly rename identifiers; parsers may call this function
when generating their identifiers; default = identity *)
val rename_id : (string -> string) ref;;

34
camlp4/ocaml_src/camlp4/reloc.mli
View File

@ -16,7 +16,41 @@ val zero_loc : Lexing.position;;
val shift_pos : int -> Lexing.position -> Lexing.position;;
val adjust_loc : Lexing.position -> MLast.loc -> MLast.loc;;
val linearize : MLast.loc -> MLast.loc;;
val ctyp : (MLast.loc -> MLast.loc) -> 'a -> MLast.ctyp -> MLast.ctyp;;
val row_field :
(MLast.loc -> MLast.loc) -> 'a -> MLast.row_field -> MLast.row_field;;
val class_infos :
((MLast.loc -> MLast.loc) -> 'a -> 'b -> 'c) -> (MLast.loc -> MLast.loc) ->
'a -> 'b MLast.class_infos -> 'c MLast.class_infos;;
val patt :
(MLast.loc -> MLast.loc) -> Lexing.position -> MLast.patt -> MLast.patt;;
val expr :
(MLast.loc -> MLast.loc) -> Lexing.position -> MLast.expr -> MLast.expr;;
val module_type :
(MLast.loc -> MLast.loc) -> Lexing.position -> MLast.module_type ->
MLast.module_type;;
val sig_item :
(MLast.loc -> MLast.loc) -> Lexing.position -> MLast.sig_item ->
MLast.sig_item;;
val with_constr :
(MLast.loc -> MLast.loc) -> Lexing.position -> MLast.with_constr ->
MLast.with_constr;;
val module_expr :
(MLast.loc -> MLast.loc) -> Lexing.position -> MLast.module_expr ->
MLast.module_expr;;
val str_item :
(MLast.loc -> MLast.loc) -> Lexing.position -> MLast.str_item ->
MLast.str_item;;
val class_type :
(MLast.loc -> MLast.loc) -> Lexing.position -> MLast.class_type ->
MLast.class_type;;
val class_sig_item :
(MLast.loc -> MLast.loc) -> Lexing.position -> MLast.class_sig_item ->
MLast.class_sig_item;;
val class_expr :
(MLast.loc -> MLast.loc) -> Lexing.position -> MLast.class_expr ->
MLast.class_expr;;
val class_str_item :
(MLast.loc -> MLast.loc) -> Lexing.position -> MLast.class_str_item ->
MLast.class_str_item;;

18
camlp4/ocaml_src/lib/Makefile
View File

@ -9,7 +9,10 @@ SHELL=/bin/sh
TARGET=gramlib.cma
all: $(TARGET)
opt: $(TARGET:.cma=.cmxa)
opt: opt$(PROFILING)
optnoprof: $(TARGET:.cma=.cmxa)
optprof: optnoprof $(TARGET:.cma=.p.cmxa)
$(TARGET): $(OBJS)
$(OCAMLC) $(OBJS) -a -o $(TARGET)
@ -17,6 +20,9 @@ $(TARGET): $(OBJS)
$(TARGET:.cma=.cmxa): $(OBJS:.cmo=.cmx)
$(OCAMLOPT) $(OBJS:.cmo=.cmx) -a -o $(TARGET:.cma=.cmxa)
$(TARGET:.cma=.p.cmxa): $(OBJS:.cmo=.p.cmx)
$(OCAMLOPT) $(OBJS:.cmo=.p.cmx) -a -o $(TARGET:.cma=.p.cmxa)
clean::
rm -f *.cm[ioax] *.cmxa *.pp[io] *.$(O) *.$(A) *.bak .*.bak $(TARGET)
@ -39,10 +45,14 @@ install:
-$(MKDIR) "$(LIBDIR)/camlp4"
cp $(TARGET) *.mli "$(LIBDIR)/camlp4/."
cp *.cmi "$(LIBDIR)/camlp4/."
if test -f $(TARGET:.cma=.cmxa); then $(MAKE) installopt LIBDIR="$(LIBDIR)"; fi
test -f $(TARGET:.cma=.cmxa) && $(MAKE) installopt LIBDIR="$(LIBDIR)" || true
installopt:
cp $(TARGET:.cma=.cmxa) *.cmx "$(LIBDIR)/camlp4/."
TARG=`echo "$(TARGET)" | sed -e "s/\.cma\$$/.$(A)/g"` && tar cf - $$TARG | (cd "$(LIBDIR)/camlp4/." && tar xf -)
for f in $(TARGET:.cma=.cmxa) $(TARGET:.cma=.p.cmxa) ; do \
test -f $$f && cp $$f "$(LIBDIR)/camlp4/." || true ; \
done
# Special treatment for this one: some versions of make don't like $(A) in $(TARGET:.cma=.$(A))
target="`echo $(TARGET) | sed -e 's/\.cma$$/.$(A))/'`" ; \
test -f $$target && cp $$target "$(LIBDIR)/camlp4/." || true
include .depend

33
camlp4/ocaml_src/lib/plexer.ml
View File

@ -602,6 +602,19 @@ let next_token_fun dfa ssd find_kwd fname lnum bolpos glexr =
Stream.Failure -> raise (Stream.Error "")
in
quotation bp len strm__
| Some '\010' ->
Stream.junk strm__;
let s = strm__ in
bolpos := bp + 1; incr lnum; quotation bp (store len '\010') s
| Some '\013' ->
Stream.junk strm__;
let s = strm__ in
let bol =
match Stream.peek s with
Some '\010' -> Stream.junk s; bp + 2
| _ -> bp + 1
in
bolpos := bol; incr lnum; quotation bp (store len '\013') s
| Some c -> Stream.junk strm__; quotation bp (store len c) strm__
| _ ->
let ep = Stream.count strm__ in
@ -1042,11 +1055,11 @@ let gmake () =
let id_table = Hashtbl.create 301 in
let glexr =
ref
{tok_func = (fun _ -> raise (Match_failure ("", 741, 17)));
tok_using = (fun _ -> raise (Match_failure ("", 741, 37)));
tok_removing = (fun _ -> raise (Match_failure ("", 741, 60)));
tok_match = (fun _ -> raise (Match_failure ("", 742, 18)));
tok_text = (fun _ -> raise (Match_failure ("", 742, 37)));
{tok_func = (fun _ -> raise (Match_failure ("", 748, 17)));
tok_using = (fun _ -> raise (Match_failure ("", 748, 37)));
tok_removing = (fun _ -> raise (Match_failure ("", 748, 60)));
tok_match = (fun _ -> raise (Match_failure ("", 749, 18)));
tok_text = (fun _ -> raise (Match_failure ("", 749, 37)));
tok_comm = None}
in
let glex =
@ -1076,11 +1089,11 @@ let make () =
let id_table = Hashtbl.create 301 in
let glexr =
ref
{tok_func = (fun _ -> raise (Match_failure ("", 770, 17)));
tok_using = (fun _ -> raise (Match_failure ("", 770, 37)));
tok_removing = (fun _ -> raise (Match_failure ("", 770, 60)));
tok_match = (fun _ -> raise (Match_failure ("", 771, 18)));
tok_text = (fun _ -> raise (Match_failure ("", 771, 37)));
{tok_func = (fun _ -> raise (Match_failure ("", 777, 17)));
tok_using = (fun _ -> raise (Match_failure ("", 777, 37)));
tok_removing = (fun _ -> raise (Match_failure ("", 777, 60)));
tok_match = (fun _ -> raise (Match_failure ("", 778, 18)));
tok_text = (fun _ -> raise (Match_failure ("", 778, 37)));
tok_comm = None}
in
{func = func kwd_table glexr; using = using_token kwd_table id_table;

12
camlp4/ocaml_src/lib/token.ml
View File

@ -223,8 +223,16 @@ let eval_string (bp, ep) s =
| c ->
try let (c, i) = backslash s i in store len c, i with
Not_found ->
Printf.eprintf "Warning: char %d, Invalid backslash escape in string\n%!"
(bp.Lexing.pos_cnum + i + 1);
let txt = "Invalid backslash escape in string" in
let pos = bp.Lexing.pos_cnum - bp.Lexing.pos_bol + i in
if bp.Lexing.pos_fname = "" then
Printf.eprintf "Warning: line %d, chars %d-%d: %s\n"
bp.Lexing.pos_lnum pos (pos + 1) txt
else
Printf.eprintf
"Warning: File \"%s\", line %d, chars %d-%d: %s\n"
bp.Lexing.pos_fname bp.Lexing.pos_lnum pos (pos + 1)
txt;
store (store len '\\') c, i + 1
else store len s.[i], i + 1
in

2
camlp4/ocaml_src/meta/.depend
View File

@ -2,8 +2,6 @@ pa_extend.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi ../camlp4/reloc.cmi
pa_extend.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx ../camlp4/reloc.cmx
pa_extend_m.cmo: pa_extend.cmo
pa_extend_m.cmx: pa_extend.cmx
pa_ifdef.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi
pa_ifdef.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx
pa_macro.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi
pa_macro.cmx: ../camlp4/mLast.cmi ../camlp4/pcaml.cmx
pa_r.cmo: ../camlp4/mLast.cmi ../camlp4/pcaml.cmi

226
camlp4/ocaml_src/meta/pa_ifdef.ml
View File

@ -1,226 +0,0 @@
(* camlp4r pa_extend.cmo q_MLast.cmo *)
(* This file has been generated by program: do not edit! *)
type 'a item_or_def =
SdStr of 'a
| SdDef of string
| SdUnd of string
| SdNop
;;
let list_remove x l =
List.fold_right (fun e l -> if e = x then l else e :: l) l []
;;
let defined = ref ["OCAML_305"; "CAMLP4_300"; "NEWSEQ"];;
let define x = defined := x :: !defined;;
let undef x = defined := list_remove x !defined;;
Grammar.extend
(let _ = (Pcaml.expr : 'Pcaml__expr Grammar.Entry.e)
and _ = (Pcaml.str_item : 'Pcaml__str_item Grammar.Entry.e)
and _ = (Pcaml.sig_item : 'Pcaml__sig_item Grammar.Entry.e) in
let grammar_entry_create s =
Grammar.Entry.create (Grammar.of_entry Pcaml.expr) s
in
let def_undef_str : 'def_undef_str Grammar.Entry.e =
grammar_entry_create "def_undef_str"
and str_item_def_undef : 'str_item_def_undef Grammar.Entry.e =
grammar_entry_create "str_item_def_undef"
and def_undef_sig : 'def_undef_sig Grammar.Entry.e =
grammar_entry_create "def_undef_sig"
and sig_item_def_undef : 'sig_item_def_undef Grammar.Entry.e =
grammar_entry_create "sig_item_def_undef"
in
[Grammar.Entry.obj (Pcaml.expr : 'Pcaml__expr Grammar.Entry.e),
Some (Gramext.Level "top"),
[None, None,
[[Gramext.Stoken ("", "ifndef"); Gramext.Stoken ("UIDENT", "");
Gramext.Stoken ("", "then"); Gramext.Sself;
Gramext.Stoken ("", "else"); Gramext.Sself],
Gramext.action
(fun (e2 : 'Pcaml__expr) _ (e1 : 'Pcaml__expr) _ (c : string) _
(loc : Lexing.position * Lexing.position) ->
(if List.mem c !defined then e2 else e1 : 'Pcaml__expr));
[Gramext.Stoken ("", "ifdef"); Gramext.Stoken ("UIDENT", "");
Gramext.Stoken ("", "then"); Gramext.Sself;
Gramext.Stoken ("", "else"); Gramext.Sself],
Gramext.action
(fun (e2 : 'Pcaml__expr) _ (e1 : 'Pcaml__expr) _ (c : string) _
(loc : Lexing.position * Lexing.position) ->
(if List.mem c !defined then e1 else e2 : 'Pcaml__expr))]];
Grammar.Entry.obj (Pcaml.str_item : 'Pcaml__str_item Grammar.Entry.e),
Some Gramext.First,
[None, None,
[[Gramext.Snterm
(Grammar.Entry.obj
(def_undef_str : 'def_undef_str Grammar.Entry.e))],
Gramext.action
(fun (x : 'def_undef_str) (loc : Lexing.position * Lexing.position) ->
(match x with
SdStr si -> si
| SdDef x -> define x; MLast.StDcl (loc, [])
| SdUnd x -> undef x; MLast.StDcl (loc, [])
| SdNop -> MLast.StDcl (loc, []) :
'Pcaml__str_item))]];
Grammar.Entry.obj (def_undef_str : 'def_undef_str Grammar.Entry.e), None,
[None, None,
[[Gramext.Stoken ("", "undef"); Gramext.Stoken ("UIDENT", "")],
Gramext.action
(fun (c : string) _ (loc : Lexing.position * Lexing.position) ->
(SdUnd c : 'def_undef_str));
[Gramext.Stoken ("", "define"); Gramext.Stoken ("UIDENT", "")],
Gramext.action
(fun (c : string) _ (loc : Lexing.position * Lexing.position) ->
(SdDef c : 'def_undef_str));
[Gramext.Stoken ("", "ifndef"); Gramext.Stoken ("UIDENT", "");
Gramext.Stoken ("", "then");
Gramext.Snterm
(Grammar.Entry.obj
(str_item_def_undef : 'str_item_def_undef Grammar.Entry.e))],
Gramext.action
(fun (e1 : 'str_item_def_undef) _ (c : string) _
(loc : Lexing.position * Lexing.position) ->
(if List.mem c !defined then SdNop else e1 : 'def_undef_str));
[Gramext.Stoken ("", "ifndef"); Gramext.Stoken ("UIDENT", "");
Gramext.Stoken ("", "then");
Gramext.Snterm
(Grammar.Entry.obj
(str_item_def_undef : 'str_item_def_undef Grammar.Entry.e));
Gramext.Stoken ("", "else");
Gramext.Snterm
(Grammar.Entry.obj
(str_item_def_undef : 'str_item_def_undef Grammar.Entry.e))],
Gramext.action
(fun (e2 : 'str_item_def_undef) _ (e1 : 'str_item_def_undef) _
(c : string) _ (loc : Lexing.position * Lexing.position) ->
(if List.mem c !defined then e2 else e1 : 'def_undef_str));
[Gramext.Stoken ("", "ifdef"); Gramext.Stoken ("UIDENT", "");
Gramext.Stoken ("", "then");
Gramext.Snterm
(Grammar.Entry.obj
(str_item_def_undef : 'str_item_def_undef Grammar.Entry.e))],
Gramext.action
(fun (e1 : 'str_item_def_undef) _ (c : string) _
(loc : Lexing.position * Lexing.position) ->
(if List.mem c !defined then e1 else SdNop : 'def_undef_str));
[Gramext.Stoken ("", "ifdef"); Gramext.Stoken ("UIDENT", "");
Gramext.Stoken ("", "then");
Gramext.Snterm
(Grammar.Entry.obj
(str_item_def_undef : 'str_item_def_undef Grammar.Entry.e));
Gramext.Stoken ("", "else");
Gramext.Snterm
(Grammar.Entry.obj
(str_item_def_undef : 'str_item_def_undef Grammar.Entry.e))],
Gramext.action
(fun (e2 : 'str_item_def_undef) _ (e1 : 'str_item_def_undef) _
(c : string) _ (loc : Lexing.position * Lexing.position) ->
(if List.mem c !defined then e1 else e2 : 'def_undef_str))]];
Grammar.Entry.obj
(str_item_def_undef : 'str_item_def_undef Grammar.Entry.e),
None,
[None, None,
[[Gramext.Snterm
(Grammar.Entry.obj
(Pcaml.str_item : 'Pcaml__str_item Grammar.Entry.e))],
Gramext.action
(fun (si : 'Pcaml__str_item)
(loc : Lexing.position * Lexing.position) ->
(SdStr si : 'str_item_def_undef));
[Gramext.Snterm
(Grammar.Entry.obj
(def_undef_str : 'def_undef_str Grammar.Entry.e))],
Gramext.action
(fun (d : 'def_undef_str) (loc : Lexing.position * Lexing.position) ->
(d : 'str_item_def_undef))]];
Grammar.Entry.obj (Pcaml.sig_item : 'Pcaml__sig_item Grammar.Entry.e),
Some Gramext.First,
[None, None,
[[Gramext.Snterm
(Grammar.Entry.obj
(def_undef_sig : 'def_undef_sig Grammar.Entry.e))],
Gramext.action
(fun (x : 'def_undef_sig) (loc : Lexing.position * Lexing.position) ->
(match x with
SdStr si -> si
| SdDef x -> define x; MLast.SgDcl (loc, [])
| SdUnd x -> undef x; MLast.SgDcl (loc, [])
| SdNop -> MLast.SgDcl (loc, []) :
'Pcaml__sig_item))]];
Grammar.Entry.obj (def_undef_sig : 'def_undef_sig Grammar.Entry.e), None,
[None, None,
[[Gramext.Stoken ("", "undef"); Gramext.Stoken ("UIDENT", "")],
Gramext.action
(fun (c : string) _ (loc : Lexing.position * Lexing.position) ->
(SdUnd c : 'def_undef_sig));
[Gramext.Stoken ("", "define"); Gramext.Stoken ("UIDENT", "")],
Gramext.action
(fun (c : string) _ (loc : Lexing.position * Lexing.position) ->
(SdDef c : 'def_undef_sig));
[Gramext.Stoken ("", "ifndef"); Gramext.Stoken ("UIDENT", "");
Gramext.Stoken ("", "then");
Gramext.Snterm
(Grammar.Entry.obj
(sig_item_def_undef : 'sig_item_def_undef Grammar.Entry.e))],
Gramext.action
(fun (e1 : 'sig_item_def_undef) _ (c : string) _
(loc : Lexing.position * Lexing.position) ->
(if List.mem c !defined then SdNop else e1 : 'def_undef_sig));
[Gramext.Stoken ("", "ifndef"); Gramext.Stoken ("UIDENT", "");
Gramext.Stoken ("", "then");
Gramext.Snterm
(Grammar.Entry.obj
(sig_item_def_undef : 'sig_item_def_undef Grammar.Entry.e));
Gramext.Stoken ("", "else");
Gramext.Snterm
(Grammar.Entry.obj
(sig_item_def_undef : 'sig_item_def_undef Grammar.Entry.e))],
Gramext.action
(fun (e2 : 'sig_item_def_undef) _ (e1 : 'sig_item_def_undef) _
(c : string) _ (loc : Lexing.position * Lexing.position) ->
(if List.mem c !defined then e2 else e1 : 'def_undef_sig));
[Gramext.Stoken ("", "ifdef"); Gramext.Stoken ("UIDENT", "");
Gramext.Stoken ("", "then");
Gramext.Snterm
(Grammar.Entry.obj
(sig_item_def_undef : 'sig_item_def_undef Grammar.Entry.e))],
Gramext.action
(fun (e1 : 'sig_item_def_undef) _ (c : string) _
(loc : Lexing.position * Lexing.position) ->
(if List.mem c !defined then e1 else SdNop : 'def_undef_sig));
[Gramext.Stoken ("", "ifdef"); Gramext.Stoken ("UIDENT", "");
Gramext.Stoken ("", "then");
Gramext.Snterm
(Grammar.Entry.obj
(sig_item_def_undef : 'sig_item_def_undef Grammar.Entry.e));
Gramext.Stoken ("", "else");
Gramext.Snterm
(Grammar.Entry.obj
(sig_item_def_undef : 'sig_item_def_undef Grammar.Entry.e))],
Gramext.action
(fun (e2 : 'sig_item_def_undef) _ (e1 : 'sig_item_def_undef) _
(c : string) _ (loc : Lexing.position * Lexing.position) ->
(if List.mem c !defined then e1 else e2 : 'def_undef_sig))]];
Grammar.Entry.obj
(sig_item_def_undef : 'sig_item_def_undef Grammar.Entry.e),
None,
[None, None,
[[Gramext.Snterm
(Grammar.Entry.obj
(Pcaml.sig_item : 'Pcaml__sig_item Grammar.Entry.e))],
Gramext.action
(fun (si : 'Pcaml__sig_item)
(loc : Lexing.position * Lexing.position) ->
(SdStr si : 'sig_item_def_undef));
[Gramext.Snterm
(Grammar.Entry.obj
(def_undef_sig : 'def_undef_sig Grammar.Entry.e))],
Gramext.action
(fun (d : 'def_undef_sig) (loc : Lexing.position * Lexing.position) ->
(d : 'sig_item_def_undef))]]]);;
Pcaml.add_option "-D" (Arg.String define)
"<string> Define for ifdef instruction.";;
Pcaml.add_option "-U" (Arg.String undef)
"<string> Undefine for ifdef instruction.";;

225
camlp4/ocaml_src/meta/pa_macro.ml
View File

@ -9,33 +9,43 @@ Added statements:
DEFINE <uident>
DEFINE <uident> = <expression>
DEFINE <uident> (<parameters>) = <expression>
IFDEF <uident> THEN <structure_items> END
IFDEF <uident> THEN <structure_items> ELSE <structure_items> END
IFNDEF <uident> THEN <structure_items> END
IFNDEF <uident> THEN <structure_items> ELSE <structure_items> END
IFDEF <uident> THEN <structure_items> (END | ENDIF)
IFDEF <uident> THEN <structure_items> ELSE <structure_items> (END | ENDIF)
IFNDEF <uident> THEN <structure_items> (END | ENDIF)
IFNDEF <uident> THEN <structure_items> ELSE <structure_items> (END | ENDIF)
INCLUDE <string>
In expressions:
IFDEF <uident> THEN <expression> ELSE <expression> END
IFNDEF <uident> THEN <expression> ELSE <expression> END
IFDEF <uident> THEN <expression> ELSE <expression> (END | ENDIF)
IFNDEF <uident> THEN <expression> ELSE <expression> (END | ENDIF)
__FILE__
__LOCATION__
In patterns:
IFDEF <uident> THEN <pattern> ELSE <pattern> END
IFNDEF <uident> THEN <pattern> ELSE <pattern> END
IFDEF <uident> THEN <pattern> ELSE <pattern> (END | ENDIF)
IFNDEF <uident> THEN <pattern> ELSE <pattern> (END | ENDIF)
As Camlp4 options:
-D<uident>
-U<uident>
-D<uident> define <uident>
-U<uident> undefine it
-I<dir> add <dir> to the search path for INCLUDE'd files
After having used a DEFINE <uident> followed by "= <expression>", you
can use it in expressions *and* in patterns. If the expression defining
the macro cannot be used as a pattern, there is an error message if
it is used in a pattern.
The toplevel statement INCLUDE <string> can be used to include a
file containing macro definitions; note that files included in such
a way can not have any non-macro toplevel items. The included files
are looked up in directories passed in via the -I option, falling
back to the current directory.
The expression __FILE__ returns the current compiled file name.
The expression __LOCATION__ returns the current location of itself.
@ -50,7 +60,8 @@ type 'a item_or_def =
SdStr of 'a
| SdDef of string * (string list * MLast.expr) option
| SdUnd of string
| SdNop
| SdITE of string * 'a item_or_def list * 'a item_or_def list
| SdInc of string
;;
let rec list_remove x =
@ -80,15 +91,32 @@ let subst mloc env =
| MLast.ExIfe (_, e1, e2, e3) ->
MLast.ExIfe (loc, loop e1, loop e2, loop e3)
| MLast.ExApp (_, e1, e2) -> MLast.ExApp (loc, loop e1, loop e2)
| MLast.ExFun (_, [args, None, e]) ->
MLast.ExFun (loc, [args, None, loop e])
| MLast.ExFun (_, peoel) -> MLast.ExFun (loc, List.map loop_peoel peoel)
| MLast.ExLid (_, x) | MLast.ExUid (_, x) as e ->
begin try MLast.ExAnt (loc, List.assoc x env) with
Not_found -> e
end
| MLast.ExTup (_, x) -> MLast.ExTup (loc, List.map loop x)
| MLast.ExSeq (_, x) -> MLast.ExSeq (loc, List.map loop x)
| MLast.ExRec (_, pel, None) ->
let pel = List.map (fun (p, e) -> p, loop e) pel in
MLast.ExRec (loc, pel, None)
| MLast.ExMat (_, e, peoel) ->
MLast.ExMat (loc, loop e, List.map loop_peoel peoel)
| MLast.ExTry (_, e, pel) ->
let loop' =
function
p, Some e1, e2 -> p, Some (loop e1), loop e2
| p, None, e2 -> p, None, loop e2
in
MLast.ExTry (loc, loop e, List.map loop' pel)
| e -> e
and loop_peoel =
function
p, Some e1, e2 -> p, Some (loop e1), loop e2
| p, None, e2 -> p, None, loop e2
in
loop
;;
@ -106,6 +134,7 @@ let substp mloc env =
Not_found -> MLast.PaUid (loc, x)
end
| MLast.ExInt (_, x) -> MLast.PaInt (loc, x)
| MLast.ExStr (_, s) -> MLast.PaStr (loc, s)
| MLast.ExTup (_, x) -> MLast.PaTup (loc, List.map loop x)
| MLast.ExRec (_, pel, None) ->
let ppl = List.map (fun (p, e) -> p, loop e) pel in
@ -206,16 +235,61 @@ let undef x =
Not_found -> ()
;;
(* This is a list of directories to search for INCLUDE statements. *)
let include_dirs = ref [];;
(* Add something to the above, make sure it ends with a slash. *)
let add_include_dir str =
if str <> "" then
let str =
if String.get str (String.length str - 1) = '/' then str else str ^ "/"
in
include_dirs := !include_dirs @ [str]
;;
let smlist = Grammar.Entry.create Pcaml.gram "smlist";;
let parse_include_file =
let dir_ok file dir = Sys.file_exists (dir ^ file) in
fun file ->
let file =
try List.find (dir_ok file) (!include_dirs @ ["./"]) ^ file with
Not_found -> file
in
let st = Stream.of_channel (open_in file) in
let old_input = !(Pcaml.input_file) in
Pcaml.input_file := file;
let items = Grammar.Entry.parse smlist st in
Pcaml.input_file := old_input; items
;;
let rec execute_macro =
function
SdStr i -> [i]
| SdDef (x, eo) -> define eo x; []
| SdUnd x -> undef x; []
| SdITE (i, l1, l2) -> execute_macro_list (if is_defined i then l1 else l2)
| SdInc f -> execute_macro_list (parse_include_file f)
and execute_macro_list =
function
[] -> []
| hd :: tl ->
let il1 = execute_macro hd in
let il2 = execute_macro_list tl in il1 @ il2
;;
Grammar.extend
(let _ = (expr : 'expr Grammar.Entry.e)
and _ = (patt : 'patt Grammar.Entry.e)
and _ = (str_item : 'str_item Grammar.Entry.e)
and _ = (sig_item : 'sig_item Grammar.Entry.e) in
and _ = (sig_item : 'sig_item Grammar.Entry.e)
and _ = (smlist : 'smlist Grammar.Entry.e) in
let grammar_entry_create s =
Grammar.Entry.create (Grammar.of_entry expr) s
in
let macro_def : 'macro_def Grammar.Entry.e =
grammar_entry_create "macro_def"
and endif : 'endif Grammar.Entry.e = grammar_entry_create "endif"
and str_item_or_macro : 'str_item_or_macro Grammar.Entry.e =
grammar_entry_create "str_item_or_macro"
and opt_macro_value : 'opt_macro_value Grammar.Entry.e =
@ -228,67 +302,56 @@ Grammar.extend
(Grammar.Entry.obj (macro_def : 'macro_def Grammar.Entry.e))],
Gramext.action
(fun (x : 'macro_def) (loc : Lexing.position * Lexing.position) ->
(match x with
SdStr [si] -> si
| SdStr sil -> MLast.StDcl (loc, sil)
| SdDef (x, eo) -> define eo x; MLast.StDcl (loc, [])
| SdUnd x -> undef x; MLast.StDcl (loc, [])
| SdNop -> MLast.StDcl (loc, []) :
(match execute_macro x with
[si] -> si
| sil -> MLast.StDcl (loc, sil) :
'str_item))]];
Grammar.Entry.obj (macro_def : 'macro_def Grammar.Entry.e), None,
[None, None,
[[Gramext.Stoken ("", "IFNDEF");
Gramext.Snterm (Grammar.Entry.obj (uident : 'uident Grammar.Entry.e));
Gramext.Stoken ("", "THEN");
Gramext.Snterm
(Grammar.Entry.obj
(str_item_or_macro : 'str_item_or_macro Grammar.Entry.e));
Gramext.Stoken ("", "ELSE");
Gramext.Snterm
(Grammar.Entry.obj
(str_item_or_macro : 'str_item_or_macro Grammar.Entry.e));
Gramext.Stoken ("", "END")],
[[Gramext.Stoken ("", "INCLUDE"); Gramext.Stoken ("STRING", "")],
Gramext.action
(fun _ (d2 : 'str_item_or_macro) _ (d1 : 'str_item_or_macro) _
(i : 'uident) _ (loc : Lexing.position * Lexing.position) ->
(if is_defined i then d2 else d1 : 'macro_def));
(fun (fname : string) _ (loc : Lexing.position * Lexing.position) ->
(SdInc fname : 'macro_def));
[Gramext.Stoken ("", "IFNDEF");
Gramext.Snterm (Grammar.Entry.obj (uident : 'uident Grammar.Entry.e));
Gramext.Stoken ("", "THEN");
Gramext.Snterm
(Grammar.Entry.obj
(str_item_or_macro : 'str_item_or_macro Grammar.Entry.e));
Gramext.Stoken ("", "END")],
Gramext.action
(fun _ (d : 'str_item_or_macro) _ (i : 'uident) _
(loc : Lexing.position * Lexing.position) ->
(if is_defined i then SdNop else d : 'macro_def));
[Gramext.Stoken ("", "IFDEF");
Gramext.Snterm (Grammar.Entry.obj (uident : 'uident Grammar.Entry.e));
Gramext.Stoken ("", "THEN");
Gramext.Snterm
(Grammar.Entry.obj
(str_item_or_macro : 'str_item_or_macro Grammar.Entry.e));
Gramext.Snterm (Grammar.Entry.obj (smlist : 'smlist Grammar.Entry.e));
Gramext.Stoken ("", "ELSE");
Gramext.Snterm
(Grammar.Entry.obj
(str_item_or_macro : 'str_item_or_macro Grammar.Entry.e));
Gramext.Stoken ("", "END")],
Gramext.Snterm (Grammar.Entry.obj (smlist : 'smlist Grammar.Entry.e));
Gramext.Snterm (Grammar.Entry.obj (endif : 'endif Grammar.Entry.e))],
Gramext.action
(fun _ (d2 : 'str_item_or_macro) _ (d1 : 'str_item_or_macro) _
(i : 'uident) _ (loc : Lexing.position * Lexing.position) ->
(if is_defined i then d1 else d2 : 'macro_def));
(fun (_ : 'endif) (dl2 : 'smlist) _ (dl1 : 'smlist) _ (i : 'uident) _
(loc : Lexing.position * Lexing.position) ->
(SdITE (i, dl2, dl1) : 'macro_def));
[Gramext.Stoken ("", "IFNDEF");
Gramext.Snterm (Grammar.Entry.obj (uident : 'uident Grammar.Entry.e));
Gramext.Stoken ("", "THEN");
Gramext.Snterm (Grammar.Entry.obj (smlist : 'smlist Grammar.Entry.e));
Gramext.Snterm (Grammar.Entry.obj (endif : 'endif Grammar.Entry.e))],
Gramext.action
(fun (_ : 'endif) (dl : 'smlist) _ (i : 'uident) _
(loc : Lexing.position * Lexing.position) ->
(SdITE (i, [], dl) : 'macro_def));
[Gramext.Stoken ("", "IFDEF");
Gramext.Snterm (Grammar.Entry.obj (uident : 'uident Grammar.Entry.e));
Gramext.Stoken ("", "THEN");
Gramext.Snterm
(Grammar.Entry.obj
(str_item_or_macro : 'str_item_or_macro Grammar.Entry.e));
Gramext.Stoken ("", "END")],
Gramext.Snterm (Grammar.Entry.obj (smlist : 'smlist Grammar.Entry.e));
Gramext.Stoken ("", "ELSE");
Gramext.Snterm (Grammar.Entry.obj (smlist : 'smlist Grammar.Entry.e));
Gramext.Snterm (Grammar.Entry.obj (endif : 'endif Grammar.Entry.e))],
Gramext.action
(fun _ (d : 'str_item_or_macro) _ (i : 'uident) _
(fun (_ : 'endif) (dl2 : 'smlist) _ (dl1 : 'smlist) _ (i : 'uident) _
(loc : Lexing.position * Lexing.position) ->
(if is_defined i then d else SdNop : 'macro_def));
(SdITE (i, dl1, dl2) : 'macro_def));
[Gramext.Stoken ("", "IFDEF");
Gramext.Snterm (Grammar.Entry.obj (uident : 'uident Grammar.Entry.e));
Gramext.Stoken ("", "THEN");
Gramext.Snterm (Grammar.Entry.obj (smlist : 'smlist Grammar.Entry.e));
Gramext.Snterm (Grammar.Entry.obj (endif : 'endif Grammar.Entry.e))],
Gramext.action
(fun (_ : 'endif) (dl : 'smlist) _ (i : 'uident) _
(loc : Lexing.position * Lexing.position) ->
(SdITE (i, dl, []) : 'macro_def));
[Gramext.Stoken ("", "UNDEF");
Gramext.Snterm (Grammar.Entry.obj (uident : 'uident Grammar.Entry.e))],
Gramext.action
@ -303,16 +366,32 @@ Grammar.extend
(fun (def : 'opt_macro_value) (i : 'uident) _
(loc : Lexing.position * Lexing.position) ->
(SdDef (i, def) : 'macro_def))]];
Grammar.Entry.obj (smlist : 'smlist Grammar.Entry.e), None,
[None, None,
[[Gramext.Slist1
(Gramext.Snterm
(Grammar.Entry.obj
(str_item_or_macro : 'str_item_or_macro Grammar.Entry.e)))],
Gramext.action
(fun (sml : 'str_item_or_macro list)
(loc : Lexing.position * Lexing.position) ->
(sml : 'smlist))]];
Grammar.Entry.obj (endif : 'endif Grammar.Entry.e), None,
[None, None,
[[Gramext.Stoken ("", "ENDIF")],
Gramext.action
(fun _ (loc : Lexing.position * Lexing.position) -> (() : 'endif));
[Gramext.Stoken ("", "END")],
Gramext.action
(fun _ (loc : Lexing.position * Lexing.position) -> (() : 'endif))]];
Grammar.Entry.obj
(str_item_or_macro : 'str_item_or_macro Grammar.Entry.e),
None,
[None, None,
[[Gramext.Slist1
(Gramext.Snterm
(Grammar.Entry.obj (str_item : 'str_item Grammar.Entry.e)))],
[[Gramext.Snterm
(Grammar.Entry.obj (str_item : 'str_item Grammar.Entry.e))],
Gramext.action
(fun (si : 'str_item list)
(loc : Lexing.position * Lexing.position) ->
(fun (si : 'str_item) (loc : Lexing.position * Lexing.position) ->
(SdStr si : 'str_item_or_macro));
[Gramext.Snterm
(Grammar.Entry.obj (macro_def : 'macro_def Grammar.Entry.e))],
@ -347,18 +426,18 @@ Grammar.extend
Gramext.Snterm (Grammar.Entry.obj (uident : 'uident Grammar.Entry.e));
Gramext.Stoken ("", "THEN"); Gramext.Sself;
Gramext.Stoken ("", "ELSE"); Gramext.Sself;
Gramext.Stoken ("", "END")],
Gramext.Snterm (Grammar.Entry.obj (endif : 'endif Grammar.Entry.e))],
Gramext.action
(fun _ (e2 : 'expr) _ (e1 : 'expr) _ (i : 'uident) _
(fun (_ : 'endif) (e2 : 'expr) _ (e1 : 'expr) _ (i : 'uident) _
(loc : Lexing.position * Lexing.position) ->
(if is_defined i then e2 else e1 : 'expr));
[Gramext.Stoken ("", "IFDEF");
Gramext.Snterm (Grammar.Entry.obj (uident : 'uident Grammar.Entry.e));
Gramext.Stoken ("", "THEN"); Gramext.Sself;
Gramext.Stoken ("", "ELSE"); Gramext.Sself;
Gramext.Stoken ("", "END")],
Gramext.Snterm (Grammar.Entry.obj (endif : 'endif Grammar.Entry.e))],
Gramext.action
(fun _ (e2 : 'expr) _ (e1 : 'expr) _ (i : 'uident) _
(fun (_ : 'endif) (e2 : 'expr) _ (e1 : 'expr) _ (i : 'uident) _
(loc : Lexing.position * Lexing.position) ->
(if is_defined i then e1 else e2 : 'expr))]];
Grammar.Entry.obj (expr : 'expr Grammar.Entry.e),
@ -382,18 +461,18 @@ Grammar.extend
Gramext.Snterm (Grammar.Entry.obj (uident : 'uident Grammar.Entry.e));
Gramext.Stoken ("", "THEN"); Gramext.Sself;
Gramext.Stoken ("", "ELSE"); Gramext.Sself;
Gramext.Stoken ("", "END")],
Gramext.Snterm (Grammar.Entry.obj (endif : 'endif Grammar.Entry.e))],
Gramext.action
(fun _ (p2 : 'patt) _ (p1 : 'patt) _ (i : 'uident) _
(fun (_ : 'endif) (p2 : 'patt) _ (p1 : 'patt) _ (i : 'uident) _
(loc : Lexing.position * Lexing.position) ->
(if is_defined i then p2 else p1 : 'patt));
[Gramext.Stoken ("", "IFDEF");
Gramext.Snterm (Grammar.Entry.obj (uident : 'uident Grammar.Entry.e));
Gramext.Stoken ("", "THEN"); Gramext.Sself;
Gramext.Stoken ("", "ELSE"); Gramext.Sself;
Gramext.Stoken ("", "END")],
Gramext.Snterm (Grammar.Entry.obj (endif : 'endif Grammar.Entry.e))],
Gramext.action
(fun _ (p2 : 'patt) _ (p1 : 'patt) _ (i : 'uident) _
(fun (_ : 'endif) (p2 : 'patt) _ (p1 : 'patt) _ (i : 'uident) _
(loc : Lexing.position * Lexing.position) ->
(if is_defined i then p1 else p2 : 'patt))]];
Grammar.Entry.obj (uident : 'uident Grammar.Entry.e), None,
@ -407,3 +486,5 @@ Pcaml.add_option "-D" (Arg.String (define None))
"<string> Define for IFDEF instruction.";;
Pcaml.add_option "-U" (Arg.String undef)
"<string> Undefine for IFDEF instruction.";;
Pcaml.add_option "-I" (Arg.String add_include_dir)
"<string> Add a directory to INCLUDE search path.";;

6
camlp4/ocaml_src/odyl/.depend
View File

@ -1,6 +1,4 @@
odyl_main.cmo: odyl_config.cmo odyl_main.cmi
odyl_main.cmx: odyl_config.cmx odyl_main.cmi
odyl.cmo: odyl_config.cmo odyl_main.cmi
odyl.cmx: odyl_config.cmx odyl_main.cmx
odyl_main.cmo: $(OTOP)/otherlibs/dynlink/dynlink.cmi odyl_config.cmo \
odyl_main.cmi
odyl_main.cmx: odyl_config.cmx \
odyl_main.cmi

24
camlp4/ocaml_src/odyl/Makefile
View File

@ -12,22 +12,34 @@ OBJS=odyl_config.cmo odyl_main.cmo
all: odyl$(EXE)
opt: odyl.cmxa odyl.cmx
opt: opt$(PROFILING)
optnoprof: odyl.cmx odyl.cmxa
optprof: optnoprof odyl.p.cmx odyl.p.cmxa
odyl$(EXE): odyl.cma odyl.cmo
$(OCAMLC) odyl.cma odyl.cmo -o odyl$(EXE)
$(OCAMLC) odyl.cma odyl.cmo -o $@
odyl.cma: $(OBJS)
$(OCAMLC) $(LINKFLAGS) dynlink.cma $(OBJS) -a -o odyl.cma
$(OCAMLC) $(LINKFLAGS) dynlink.cma $(OBJS) -a -o $@
odyl.cmxa: $(OBJS:.cmo=.cmx)
$(OCAMLOPT) $(LINKFLAGS) $(OBJS:.cmo=.cmx) -a -o odyl.cmxa
$(OCAMLOPT) $(LINKFLAGS) $(OBJS:.cmo=.cmx) -a -o $@
odyl.p.cmxa: $(OBJS:.cmo=.p.cmx)
$(OCAMLOPT) $(LINKFLAGS) $(OBJS:.cmo=.p.cmx) -a -o $@
odyl_main.cmx: odyl_main.ml
$(CAMLP4_COMM) -nolib -DOPT -o odyl_main.ppo odyl_main.ml
$(OCAMLOPT) -c -impl odyl_main.ppo
rm -f odyl_main.ppo
odyl_main.p.cmx: odyl_main.ml
$(CAMLP4_COMM) -nolib -DOPT -o odyl_main.ppo odyl_main.ml
$(OCAMLOPT) -p -c -o $@ -impl odyl_main.ppo
rm -f odyl_main.ppo
odyl_config.ml:
(echo 'let standard_library ='; \
echo ' try Sys.getenv "CAMLP4LIB" with Not_found -> '; \
@ -56,6 +68,8 @@ compare:
install:
-$(MKDIR) "$(LIBDIR)/camlp4" "$(BINDIR)"
cp odyl.cmo odyl.cma odyl_main.cmi $(LIBDIR)/camlp4/.
if test -f odyl.cmxa; then cp odyl.cmxa odyl.$(A) $(LIBDIR)/camlp4/.; fi
for f in odyl.$(A) odyl.p.$(A) odyl.cmx odyl.o odyl.p.cmx odyl.p.o odyl.cmxa odyl.p.cmxa ; do \
test -f $$f && cp $$f "$(LIBDIR)/camlp4/." || true; \
done
include .depend

4
camlp4/ocaml_src/odyl/odyl.ml
View File

@ -27,6 +27,10 @@ let apply_load () =
flush stdout;
exit 0
end
else if s = "-version" then
begin
print_string Sys.ocaml_version; print_newline (); flush stdout; exit 0
end
else if s = "--" then begin incr i; stop := true; () end
else if String.length s > 0 && s.[0] == '-' then stop := true
else if

3
camlp4/ocaml_src/odyl/odyl_main.ml
View File

@ -20,8 +20,7 @@ let first_arg_no_load () =
if i < Array.length Sys.argv then
match Sys.argv.(i) with
"-I" -> loop (i + 2)
| "-nolib" -> loop (i + 1)
| "-where" -> loop (i + 1)
| "-nolib" | "-where" | "-version" -> loop (i + 1)
| "--" -> i + 1
| s ->
if Filename.check_suffix s ".cmo" || Filename.check_suffix s ".cma"

6
camlp4/odyl/.depend
View File

@ -1,6 +1,4 @@
odyl.cmo: odyl_config.cmo odyl_main.cmi
odyl.cmx: odyl_config.cmx odyl_main.cmx
odyl_main.cmo: $(OTOP)/otherlibs/dynlink/dynlink.cmi odyl_config.cmo \
odyl_main.cmi
odyl_main.cmx: odyl_config.cmx \
odyl_main.cmi
odyl_main.cmo: odyl_config.cmo odyl_main.cmi
odyl_main.cmx: odyl_config.cmx odyl_main.cmi

24
camlp4/odyl/Makefile
View File

@ -12,22 +12,34 @@ OBJS=odyl_config.cmo odyl_main.cmo
all: odyl$(EXE)
opt: odyl.cmxa odyl.cmx
opt: opt$(PROFILING)
optnoprof: odyl.cmx odyl.cmxa
optprof: optnoprof odyl.p.cmx odyl.p.cmxa
odyl$(EXE): odyl.cma odyl.cmo
$(OCAMLC) odyl.cma odyl.cmo -o odyl$(EXE)
$(OCAMLC) odyl.cma odyl.cmo -o $@
odyl.cma: $(OBJS)
$(OCAMLC) $(LINKFLAGS) dynlink.cma $(OBJS) -a -o odyl.cma
$(OCAMLC) $(LINKFLAGS) dynlink.cma $(OBJS) -a -o $@
odyl.cmxa: $(OBJS:.cmo=.cmx)
$(OCAMLOPT) $(LINKFLAGS) $(OBJS:.cmo=.cmx) -a -o odyl.cmxa
$(OCAMLOPT) $(LINKFLAGS) $(OBJS:.cmo=.cmx) -a -o $@
odyl.p.cmxa: $(OBJS:.cmo=.p.cmx)
$(OCAMLOPT) $(LINKFLAGS) $(OBJS:.cmo=.p.cmx) -a -o $@
odyl_main.cmx: odyl_main.ml
$(CAMLP4_COMM) -nolib -DOPT -o odyl_main.ppo odyl_main.ml
$(OCAMLOPT) -c -impl odyl_main.ppo
rm -f odyl_main.ppo
odyl_main.p.cmx: odyl_main.ml
$(CAMLP4_COMM) -nolib -DOPT -o odyl_main.ppo odyl_main.ml
$(OCAMLOPT) -p -c -o $@ -impl odyl_main.ppo
rm -f odyl_main.ppo
odyl_config.ml:
(echo 'let standard_library ='; \
echo ' try Sys.getenv "CAMLP4LIB" with Not_found -> '; \
@ -56,6 +68,8 @@ compare:
install:
-$(MKDIR) "$(LIBDIR)/camlp4" "$(BINDIR)"
cp odyl.cmo odyl.cma odyl_main.cmi $(LIBDIR)/camlp4/.
if test -f odyl.cmxa; then cp odyl.cmxa odyl.$(A) $(LIBDIR)/camlp4/.; fi
for f in odyl.$(A) odyl.p.$(A) odyl.cmx odyl.o odyl.p.cmx odyl.p.o odyl.cmxa odyl.p.cmxa ; do \
test -f $$f && cp $$f "$(LIBDIR)/camlp4/." || true; \
done
include .depend

6
camlp4/odyl/odyl.ml
View File

@ -28,6 +28,12 @@ value apply_load () =
flush stdout;
exit 0
}
else if s = "-version" then do {
print_string Sys.ocaml_version;
print_newline ();
flush stdout;
exit 0
}
else if s = "--" then do { incr i; stop.val := True; () }
else if String.length s > 0 && s.[0] == '-' then stop.val := True
else if Filename.check_suffix s ".cmo" || Filename.check_suffix s ".cma"

6
camlp4/odyl/odyl_main.ml
View File

@ -20,12 +20,12 @@ value first_arg_no_load () =
if i < Array.length Sys.argv then
match Sys.argv.(i) with
[ "-I" -> loop (i + 2)
| "-nolib" -> loop (i + 1)
| "-where" -> loop (i + 1)
| ("-nolib" | "-where" | "-version") -> loop (i + 1)
| "--" -> i + 1
| s ->
if Filename.check_suffix s ".cmo"
|| Filename.check_suffix s ".cma" then loop (i + 1)
|| Filename.check_suffix s ".cma"
then loop (i + 1)
else i ]
else i
;

8
camlp4/tools/apply.sh
View File

@ -1,11 +1,13 @@
#!/bin/sh
# $Id$
P4TOP=..
ARGS1=
FILE=
while test "" != "$1"; do
case $1 in
*.ml*) FILE=$1;;
-top) P4TOP="$2"; shift;;
*) ARGS1="$ARGS1 $1";;
esac
shift
@ -18,14 +20,14 @@ test -s "$FILE" || exit 1
set - `awk 'NR == 1' "$FILE"`
if test "$2" = "camlp4r" -o "$2" = "camlp4"; then
COMM="../boot/$2 -nolib -I ../boot -I ../etc"
COMM="$P4TOP/boot/$2 -nolib -I $P4TOP/boot -I $P4TOP/etc"
shift; shift
ARGS2=`echo $* | sed -e "s/[()*]//g"`
else
COMM="../boot/camlp4 -nolib -I ../boot -I ../etc pa_o.cmo"
COMM="$P4TOP/boot/camlp4 -nolib -I $P4TOP/boot -I $P4TOP/etc pa_o.cmo"
ARGS2=
fi
OTOP=../..
OTOP=$P4TOP/..
echo $OTOP/boot/ocamlrun $COMM $ARGS2 $ARGS1 $FILE 1>&2
$OTOP/boot/ocamlrun $COMM $ARGS2 $ARGS1 $FILE

6
camlp4/top/Makefile
View File

@ -8,13 +8,10 @@ OCAMLCFLAGS=-warn-error A $(INCLUDES)
CAMLP4_OBJS=$(OTOP)/utils/config.cmo ../boot/stdpp.cmo ../boot/token.cmo ../boot/plexer.cmo ../boot/gramext.cmo ../boot/grammar.cmo ../boot/extfold.cmo ../boot/extfun.cmo ../boot/fstream.cmo ../camlp4/quotation.cmo ../camlp4/reloc.cmo ../camlp4/spretty.cmo ../camlp4/pcaml.cmo ../camlp4/ast2pt.cmo
TOP=camlp4_top.cmo
ROBJS=$(CAMLP4_OBJS) ../meta/pa_r.cmo ../meta/pa_rp.cmo rprint.cmo $(TOP)
# pa_scheme needs to use new locations SOBJS=$(CAMLP4_OBJS) ../etc/pa_scheme.cmo $(TOP)
SOBJS=$(CAMLP4_OBJS) $(TOP)
OOBJS=$(CAMLP4_OBJS) ../etc/pa_o.cmo ../etc/pa_op.cmo $(TOP)
OOOBJS=$(CAMLP4_OBJS) ../etc/pa_o.cmo ../etc/pa_oop.cmo $(TOP)
OBJS=$(OTOP)/utils/config.cmo ../camlp4/quotation.cmo ../camlp4/reloc.cmo ../camlp4/spretty.cmo ../camlp4/pcaml.cmo ../camlp4/ast2pt.cmo camlp4_top.cmo
# camlp4sch.cma needs to use new locations TARGET=camlp4o.cma camlp4r.cma camlp4sch.cma camlp4_top.cma
TARGET=camlp4o.cma camlp4r.cma camlp4_top.cma
all: $(TARGET)
@ -28,9 +25,6 @@ camlp4o.cma: $(OOBJS)
camlp4r.cma: $(ROBJS)
$(OCAMLC) $(ROBJS) -linkall -a -o camlp4r.cma
camlp4sch.cma: $(SOBJS)
$(OCAMLC) $(SOBJS) -linkall -a -o camlp4sch.cma
camlp4_top.cma: $(OBJS)
$(OCAMLC) $(OBJS) -a -o camlp4_top.cma

60
configure vendored
View File

@ -586,6 +586,7 @@ case "$host" in
ia64-*-freebsd*) arch=ia64; system=freebsd;;
x86_64-*-linux*) arch=amd64; system=linux;;
x86_64-*-freebsd*) arch=amd64; system=freebsd;;
x86_64-*-openbsd*) arch=amd64; system=openbsd;;
esac
if test -z "$ccoption"; then
@ -608,9 +609,10 @@ case "$arch,$nativecc,$system,$host_type" in
nativecclinkopts="-n32 -Wl,-woff,84";;
*,*,nextstep,*) nativecccompopts="$gcc_warnings -U__GNUC__ -posix"
nativecclinkopts="-posix";;
*,*,rhapsody,*darwin6*)
*,*,rhapsody,*darwin[1-5].*)
nativecccompopts="$gcc_warnings -DSHRINKED_GNUC";;
*,*,rhapsody,*)
nativecccompopts="$gcc_warnings -DDARWIN_VERSION_6 $dl_defs";;
*,*,rhapsody,*) nativecccompopts="$gcc_warnings -DSHRINKED_GNUC";;
*,gcc*,cygwin,*) nativecccompopts="$gcc_warnings -U_WIN32";;
*,gcc*,*,*) nativecccompopts="$gcc_warnings";;
esac
@ -1061,37 +1063,37 @@ echo "BNG_ASM_LEVEL=$bng_asm_level" >> Makefile
# Determine if the POSIX threads library is supported
case "$host" in
*-*-solaris*) pthread_link="-lpthread -lposix4";;
*-*-freebsd*) pthread_link="-pthread";;
*-*-openbsd*) pthread_link="-pthread";;
*) pthread_link="-lpthread";;
esac
if test "$pthread_wanted" = "yes"; then
if ./hasgot -i pthread.h $pthread_link pthread_self; then
echo "POSIX threads library supported."
otherlibraries="$otherlibraries systhreads"
bytecccompopts="$bytecccompopts -D_REENTRANT"
nativecccompopts="$nativecccompopts -D_REENTRANT"
case "$host" in
*-*-freebsd*)
bytecccompopts="$bytecccompopts -D_THREAD_SAFE"
nativecccompopts="$nativecccompopts -D_THREAD_SAFE";;
*-*-openbsd*)
bytecccompopts="$bytecccompopts -pthread"
asppflags="$asppflags -pthread"
nativecccompopts="$nativecccompopts -pthread";;
*-*-solaris*) pthread_link="-lpthread -lposix4";;
*-*-freebsd*) pthread_link="-pthread";;
*-*-openbsd*) pthread_link="-pthread";;
*) pthread_link="-lpthread";;
esac
echo "Options for linking with POSIX threads: $pthread_link"
echo "PTHREAD_LINK=$pthread_link" >> Makefile
if sh ./hasgot $pthread_link sigwait; then
echo "sigwait() found"
echo "#define HAS_SIGWAIT" >> s.h
if ./hasgot -i pthread.h $pthread_link pthread_self; then
echo "POSIX threads library supported."
otherlibraries="$otherlibraries systhreads"
bytecccompopts="$bytecccompopts -D_REENTRANT"
nativecccompopts="$nativecccompopts -D_REENTRANT"
case "$host" in
*-*-freebsd*)
bytecccompopts="$bytecccompopts -D_THREAD_SAFE"
nativecccompopts="$nativecccompopts -D_THREAD_SAFE";;
*-*-openbsd*)
bytecccompopts="$bytecccompopts -pthread"
asppflags="$asppflags -pthread"
nativecccompopts="$nativecccompopts -pthread";;
esac
echo "Options for linking with POSIX threads: $pthread_link"
echo "PTHREAD_LINK=$pthread_link" >> Makefile
if sh ./hasgot $pthread_link sigwait; then
echo "sigwait() found"
echo "#define HAS_SIGWAIT" >> s.h
fi
else
echo "POSIX threads not found."
pthread_link=""
fi
else
echo "POSIX threads not found."
fi
fi
# Determine if the bytecode thread library is supported