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

remove camlp4 

git-svn-id: http://caml.inria.fr/svn/ocaml/branches/minus-camlp4@14309 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02
master
Jérémie Dimino 2013-11-21 16:23:28 +00:00
parent 94f29d29c3
commit 5d917633ad
344 changed files with 30 additions and 129985 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
Changes
View File

@ -3,6 +3,9 @@ Next version:
(Changes that can break existing programs are marked with a "*")
Camlp4:
- Removed from the official distribution
Other libraries:
* Labltk: removed from the distribution, now available as a third-party library

9
INSTALL
View File

@ -15,8 +15,8 @@ PREREQUISITES
are all *required*. The vendor-provided compiler, assembler and make
have major problems.
* GNU make is needed to build ocamlbuild and camlp4. If your system's
default make is not GNU make, you need to define the GNUMAKE environment
* GNU make is needed to build ocamlbuild. If your system's default
make is not GNU make, you need to define the GNUMAKE environment
variable to the name of GNU make, typically with this command:
export GNUMAKE=gnumake
@ -111,9 +111,6 @@ The "configure" script accepts the following options:
Verbose output of the configuration tests. Use it if the outcome
of configure is not what you were expecting.
-no-camlp4
Do not compile Camlp4.
-no-debugger
Do not build ocamldebug.
@ -121,7 +118,7 @@ The "configure" script accepts the following options:
Do not build ocamldoc.
-no-ocamlbuild
Do not build ocamlbuild. This requires -no-camlp4.
Do not build ocamlbuild.
-no-graph
Do not compile the Graphics library.

2
LICENSE
View File

@ -1,7 +1,7 @@
In the following, "the Library" refers to all files marked "Copyright
INRIA" in the following directories and their sub-directories:
asmrun, byterun, camlp4, config, otherlibs, stdlib, win32caml
asmrun, byterun, config, otherlibs, stdlib, win32caml
and "the Compiler" refers to all files marked "Copyright INRIA" in the
following directories and their sub-directories:

21
Makefile
View File

@ -29,9 +29,6 @@ DEPFLAGS=$(INCLUDES)
SHELL=/bin/sh
MKDIR=mkdir -p
CAMLP4OUT=$(WITH_CAMLP4:=out)
CAMLP4OPT=$(WITH_CAMLP4:=opt)
OCAMLBUILDBYTE=$(WITH_OCAMLBUILD:=.byte)
OCAMLBUILDNATIVE=$(WITH_OCAMLBUILD:=.native)
OCAMLBUILDLIBNATIVE=$(WITH_OCAMLBUILD:=lib.native)
@ -131,7 +128,7 @@ all:
$(MAKE) ocamltools
$(MAKE) library
$(MAKE) ocaml
$(MAKE) otherlibraries $(OCAMLBUILDBYTE) $(CAMLP4OUT) $(WITH_DEBUGGER) \
$(MAKE) otherlibraries $(OCAMLBUILDBYTE) $(WITH_DEBUGGER) \
$(WITH_OCAMLDOC)
# Compile everything the first time
@ -276,11 +273,11 @@ opt.opt:
$(MAKE) opt-core
$(MAKE) ocamlc.opt
$(MAKE) otherlibraries $(WITH_DEBUGGER) $(WITH_OCAMLDOC) \
$(OCAMLBUILDBYTE) $(CAMLP4OUT)
$(OCAMLBUILDBYTE)
$(MAKE) ocamlopt.opt
$(MAKE) otherlibrariesopt
$(MAKE) ocamllex.opt ocamltoolsopt ocamltoolsopt.opt $(OCAMLDOC_OPT) \
$(OCAMLBUILDNATIVE) $(CAMLP4OPT)
$(OCAMLBUILDNATIVE)
base.opt:
$(MAKE) checkstack
@ -289,7 +286,7 @@ base.opt:
$(MAKE) ocaml
$(MAKE) opt-core
$(MAKE) ocamlc.opt
$(MAKE) otherlibraries $(OCAMLBUILDBYTE) $(CAMLP4OUT) $(WITH_DEBUGGER) \
$(MAKE) otherlibraries $(OCAMLBUILDBYTE) $(WITH_DEBUGGER) \
$(WITH_OCAMLDOC)
$(MAKE) ocamlopt.opt
$(MAKE) otherlibrariesopt
@ -772,14 +769,6 @@ partialclean::
alldepend::
cd debugger; $(MAKE) depend
# Camlp4
camlp4out: ocamlc ocamlbuild.byte
./build/camlp4-byte-only.sh
camlp4opt: ocamlopt otherlibrariesopt ocamlbuild-mixed-boot ocamlbuild.native
./build/camlp4-native-only.sh
# Ocamlbuild
#ifeq ($(OCAMLBUILD_NOBOOT),"yes")
#ocamlbuild.byte: ocamlc
@ -855,7 +844,7 @@ distclean:
./build/distclean.sh
rm -f ocaml testsuite/_log
.PHONY: all backup bootstrap camlp4opt camlp4out checkstack clean
.PHONY: all backup bootstrap checkstack clean
.PHONY: partialclean beforedepend alldepend cleanboot coldstart
.PHONY: compare core coreall
.PHONY: coreboot defaultentry depend distclean install installopt

16
Makefile.nt
View File

@ -27,9 +27,6 @@ CAMLLEX=boot/ocamlrun boot/ocamllex
CAMLDEP=boot/ocamlrun tools/ocamldep
DEPFLAGS=$(INCLUDES)
CAMLP4OUT=$(WITH_CAMLP4:=out)
CAMLP4OPT=$(WITH_CAMLP4:=opt)
OCAMLBUILDBYTE=$(WITH_OCAMLBUILD:=.byte)
OCAMLBUILDNATIVE=$(WITH_OCAMLBUILD:=.native)
@ -112,7 +109,7 @@ defaultentry:
# Recompile the system using the bootstrap compiler
all: runtime ocamlc ocamllex ocamlyacc ocamltools library ocaml \
otherlibraries $(OCAMLBUILDBYTE) $(CAMLP4OUT) $(WITH_DEBUGGER) \
otherlibraries $(OCAMLBUILDBYTE) $(WITH_DEBUGGER) \
$(WITH_OCAMLDOC)
# The compilation of ocaml will fail if the runtime has changed.
@ -215,7 +212,7 @@ opt:
# Native-code versions of the tools
opt.opt: core opt-core ocamlc.opt all ocamlopt.opt ocamllex.opt \
ocamltoolsopt.opt $(OCAMLBUILDNATIVE) $(CAMLP4OPT) $(OCAMLDOC_OPT)
ocamltoolsopt.opt $(OCAMLBUILDNATIVE) $(OCAMLDOC_OPT)
# Complete build using fast compilers
world.opt: coldstart opt.opt
@ -661,13 +658,6 @@ partialclean::
alldepend::
cd debugger; $(MAKEREC) depend
# Camlp4
camlp4out: ocamlc otherlibraries ocamlbuild-mixed-boot ocamlbuild.byte
./build/camlp4-byte-only.sh
camlp4opt: ocamlopt otherlibrariesopt ocamlbuild-mixed-boot ocamlbuild.native
./build/camlp4-native-only.sh
# Ocamlbuild
ocamlbuild.byte: ocamlc otherlibraries ocamlbuild-mixed-boot
@ -722,7 +712,7 @@ alldepend:: depend
distclean:
./build/distclean.sh
.PHONY: all backup bootstrap camlp4opt camlp4out checkstack clean
.PHONY: all backup bootstrap checkstack clean
.PHONY: partialclean beforedepend alldepend cleanboot coldstart
.PHONY: compare core coreall
.PHONY: coreboot defaultentry depend distclean install installopt

1
README
View File

@ -54,7 +54,6 @@ CONTENTS:
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

2
README.win32
View File

@ -297,7 +297,7 @@ launch the C compiler.
In order to recompile flexdll, you first need to configure, compile,
and install OCaml without flexdll support (configure with options
-no-shared-libs -no-camlp4), then modify the flexdll Makefile to change
-no-shared-libs), then modify the flexdll Makefile to change
line 51 from:
LINKFLAGS = -ccopt "-link version_res.o"
to:

12
_tags
View File

@ -15,7 +15,7 @@
true: -traverse
# Traverse only these directories
<{bytecomp,driver,stdlib,tools,asmcomp,camlp4,ocamlbuild,toplevel,ocamldoc,typing,otherlibs,utils,debugger,lex,parsing,byterun,asmrun}/**>: traverse
<{bytecomp,driver,stdlib,tools,asmcomp,ocamlbuild,toplevel,ocamldoc,typing,otherlibs,utils,debugger,lex,parsing,byterun,asmrun}/**>: traverse
"ocamlbuild/test" or "ocamlbuild/testsuite": -traverse
@ -44,16 +44,6 @@ true: use_stdlib
<ocamldoc/*.ml*>: include_unix, include_str, include_dynlink
<ocamldoc/odoc.{byte,native}>: use_unix, use_str, use_dynlink
<camlp4/**/*.ml*>: camlp4boot, warn_Z
<camlp4/Camlp4_{config,import}.ml*>: -camlp4boot
"camlp4/Camlp4_import.ml": -warn_Z
<camlp4/build/*> or <camlp4/boot/*> or "camlp4/Camlp4/Struct/Lexer.ml": -camlp4boot, -warn_Z, warn_a
<camlp4/Camlp4Bin.{byte,native}> or <camlp4/{mkcamlp4,boot/camlp4boot}.byte>: use_dynlink
<camlp4/Camlp4Printers/**.ml>: include_unix
"camlp4/Camlp4/Struct/DynLoader.ml" or "camlp4/boot/Camlp4.ml": include_dynlink
<camlp4/Camlp4Top/**>: include_toplevel
<camlp4/camlp4{,boot,o,r,of,rf,oof,orf}.byte>: -debug
<ocamlbuild/*>: include_unix
<**/pervasives.ml> or <**/pervasives.mli> or <**/camlinternalOO.mli>: nopervasives

1
build/boot.sh
View File

@ -16,7 +16,6 @@ cd `dirname $0`/..
set -ex
TAG_LINE='true: -use_stdlib'
# If you modify this list, modify it also in camlp4-native-only.sh and camlp4-byte-only.sh
STDLIB_MODULES='Pervasives,Arg,Array,Buffer,Char,Digest,Filename,Format,Hashtbl,Lazy,Lexing,List,Map,Printexc,Printf,Scanf,Set,String,Sys,Parsing,Int32,Int64,Nativeint,Obj,Queue,Sort,Stream,Stack'
./boot/ocamlrun boot/myocamlbuild.boot -ignore "$STDLIB_MODULES" \

10
build/distclean.sh
View File

@ -27,17 +27,11 @@ rm -f boot/ocamlrun boot/ocamlrun.exe boot/camlheader \
# from partial boot
rm -f driver/main.byte driver/optmain.byte lex/main.byte \
tools/ocamlmklib.byte camlp4/build/location.ml \
camlp4/build/location.mli \
tools/myocamlbuild_config.ml camlp4/build/linenum.mli \
camlp4/build/linenum.mll \
camlp4/build/terminfo.mli camlp4/build/terminfo.ml
tools/ocamlmklib.byte \
tools/myocamlbuild_config.ml
# from ocamlbuild bootstrap
rm -f ocamlbuild/_log ocamlbuild/,ocamlbuild.byte.start \
ocamlbuild/boot/ocamlbuild ocamlbuild/myocamlbuild_config.ml \
ocamlbuild/myocamlbuild_config.mli
rm -rf ocamlbuild/_build ocamlbuild/_start
# from the old build system
rm -f camlp4/build/camlp4_config.ml camlp4/**/*.cm*

2
build/fastworld.sh
View File

@ -40,7 +40,7 @@ cp _build/myocamlbuild boot/myocamlbuild.native
./boot/myocamlbuild.native $@ \
$OCAMLC_NATIVE $TOPLEVEL $OTHERLIBS_BYTE $OTHERLIBS_NATIVE $OCAMLLEX_BYTE \
$OCAMLLEX_NATIVE $TOOLS_BYTE $TOOLS_NATIVE $DEBUGGER \
$OCAMLDOC_BYTE $OCAMLDOC_NATIVE $OCAMLBUILD_BYTE $CAMLP4_BYTE $CAMLP4_NATIVE
$OCAMLDOC_BYTE $OCAMLDOC_NATIVE $OCAMLBUILD_BYTE
cd tools
make objinfo_helper

40
build/install.sh
View File

@ -99,7 +99,6 @@ installlibdir() {
mkdir -p $BINDIR
mkdir -p $LIBDIR
mkdir -p $LIBDIR/caml
mkdir -p $LIBDIR/camlp4
mkdir -p $LIBDIR/vmthreads
mkdir -p $LIBDIR/threads
mkdir -p $LIBDIR/ocamlbuild
@ -439,45 +438,6 @@ installdir \
ocamldoc/stdlib_man/* \
$MANDIR/man3
echo "Installing camlp4..."
installbin camlp4/camlp4prof.byte$EXE $BINDIR/camlp4prof$EXE
installbin camlp4/mkcamlp4.byte$EXE $BINDIR/mkcamlp4$EXE
installbin camlp4/camlp4.byte$EXE $BINDIR/camlp4$EXE
installbin camlp4/camlp4boot.byte$EXE $BINDIR/camlp4boot$EXE
installbin camlp4/camlp4o.byte$EXE $BINDIR/camlp4o$EXE
installbin camlp4/camlp4of.byte$EXE $BINDIR/camlp4of$EXE
installbin camlp4/camlp4oof.byte$EXE $BINDIR/camlp4oof$EXE
installbin camlp4/camlp4orf.byte$EXE $BINDIR/camlp4orf$EXE
installbin camlp4/camlp4r.byte$EXE $BINDIR/camlp4r$EXE
installbin camlp4/camlp4rf.byte$EXE $BINDIR/camlp4rf$EXE
installbin camlp4/camlp4o.native$EXE $BINDIR/camlp4o.opt$EXE
installbin camlp4/camlp4of.native$EXE $BINDIR/camlp4of.opt$EXE
installbin camlp4/camlp4oof.native$EXE $BINDIR/camlp4oof.opt$EXE
installbin camlp4/camlp4orf.native$EXE $BINDIR/camlp4orf.opt$EXE
installbin camlp4/camlp4r.native$EXE $BINDIR/camlp4r.opt$EXE
installbin camlp4/camlp4rf.native$EXE $BINDIR/camlp4rf.opt$EXE
cd camlp4
CAMLP4DIR=$LIBDIR/camlp4
for dir in Camlp4Parsers Camlp4Printers Camlp4Filters Camlp4Top; do
echo "Installing $dir..."
mkdir -p $CAMLP4DIR/$dir
installdir \
$dir/*.cm* \
$dir/*.$O \
$CAMLP4DIR/$dir
done
installdir \
camlp4lib.cma camlp4lib.cmxa Camlp4.cmi \
camlp4fulllib.cma camlp4fulllib.cmxa \
camlp4o.cma camlp4of.cma camlp4oof.cma \
camlp4orf.cma camlp4r.cma camlp4rf.cma \
Camlp4Bin.cm[iox] Camlp4Bin.$O Camlp4Top.cm[io] \
Camlp4_config.cmi camlp4prof.cm[iox] camlp4prof.$O Camlp4_import.cmi \
$CAMLP4DIR
installlibdir camlp4lib.$A camlp4fulllib.$A $CAMLP4DIR
cd ..
echo "Installing ocamlbuild..."
cd ocamlbuild

7
build/new-build-system
View File

@ -30,7 +30,6 @@ build/
fastworld.sh # Same as above but faster
boot-c-parts.sh # Compile byterun, ocamlyacc and asmrun with the Makefiles
boot.sh # Compile the stdlib and ocamlc
camlp4-targets.sh # Setup camlp4 targets
otherlibs-targets.sh # Setup otherlibs targets
targets.sh # All targets of the OCaml distribution
@ -41,11 +40,7 @@ build/
myocamlbuild.sh # Regenerate the boot/myocamlbuild program
mk_shell_and_ocamlbuild_config.sh # Generate config/config.sh and myocamlbuild_config.ml
camlp4-bootstrap.sh
# Partial stuffs (just camlp4 and ocamlbuild)
# Partial stuffs
mixed-boot.sh
camlp4-byte-only.sh
camlp4-native-only.sh
ocamlbuild-byte-only.sh
ocamlbuild-native-only.sh

42
build/partial-install.sh
View File

@ -114,54 +114,12 @@ installlibdir() {
mkdir -p $BINDIR
mkdir -p $LIBDIR
mkdir -p $LIBDIR/camlp4
mkdir -p $LIBDIR/ocamlbuild
mkdir -p $MANDIR/man1
mkdir -p $MANDIR/man3
cd _build
if [ -n "${WITH_CAMLP4}" ]; then
echo "Installing camlp4..."
installbin camlp4/camlp4prof.byte$EXE $BINDIR/camlp4prof$EXE
installbin camlp4/mkcamlp4.byte$EXE $BINDIR/mkcamlp4$EXE
installbin camlp4/camlp4.byte$EXE $BINDIR/camlp4$EXE
installbin camlp4/camlp4boot.byte$EXE $BINDIR/camlp4boot$EXE
installbin camlp4/camlp4o.byte$EXE $BINDIR/camlp4o$EXE
installbin camlp4/camlp4of.byte$EXE $BINDIR/camlp4of$EXE
installbin camlp4/camlp4oof.byte$EXE $BINDIR/camlp4oof$EXE
installbin camlp4/camlp4orf.byte$EXE $BINDIR/camlp4orf$EXE
installbin camlp4/camlp4r.byte$EXE $BINDIR/camlp4r$EXE
installbin camlp4/camlp4rf.byte$EXE $BINDIR/camlp4rf$EXE
installbin camlp4/camlp4o.native$EXE $BINDIR/camlp4o.opt$EXE
installbin camlp4/camlp4of.native$EXE $BINDIR/camlp4of.opt$EXE
installbin camlp4/camlp4oof.native$EXE $BINDIR/camlp4oof.opt$EXE
installbin camlp4/camlp4orf.native$EXE $BINDIR/camlp4orf.opt$EXE
installbin camlp4/camlp4r.native$EXE $BINDIR/camlp4r.opt$EXE
installbin camlp4/camlp4rf.native$EXE $BINDIR/camlp4rf.opt$EXE
cd camlp4
CAMLP4DIR=$LIBDIR/camlp4
for dir in Camlp4Parsers Camlp4Printers Camlp4Filters Camlp4Top; do
echo "Installing $dir..."
mkdir -p $CAMLP4DIR/$dir
installdir \
$dir/*.cm* \
$dir/*.$O \
$CAMLP4DIR/$dir
done
installdir \
camlp4lib.cma camlp4lib.cmxa Camlp4.cmi \
camlp4fulllib.cma camlp4fulllib.cmxa \
camlp4o.cma camlp4of.cma camlp4oof.cma \
camlp4orf.cma camlp4r.cma camlp4rf.cma \
Camlp4Bin.cm[iox] Camlp4Bin.$O Camlp4Top.cm[io] \
Camlp4_config.cmi camlp4prof.cm[iox] camlp4prof.$O Camlp4_import.cmi \
$CAMLP4DIR
installlibdir camlp4lib.$A camlp4fulllib.$A $CAMLP4DIR
cd ..
fi
if [ -n "${WITH_OCAMLBUILD}" ]; then
echo "Installing ocamlbuild..."
cd ocamlbuild

1
build/targets.sh
View File

@ -12,7 +12,6 @@
. config/config.sh
. build/otherlibs-targets.sh
. build/camlp4-targets.sh
INSTALL_BIN="$BINDIR"
export INSTALL_BIN

4
build/world.all.sh
View File

@ -19,6 +19,6 @@ set -x
$OCAMLBUILD $@ \
$STDLIB_BYTE $OCAMLC_BYTE $OCAMLLEX_BYTE $OCAMLOPT_BYTE $TOPLEVEL \
$TOOLS_BYTE $OTHERLIBS_BYTE $OCAMLBUILD_BYTE $DEBUGGER $OCAMLDOC_BYTE \
$CAMLP4_BYTE $STDLIB_NATIVE $OCAMLC_NATIVE $OCAMLOPT_NATIVE \
$STDLIB_NATIVE $OCAMLC_NATIVE $OCAMLOPT_NATIVE \
$OCAMLLEX_NATIVE $TOOLS_NATIVE $OTHERLIBS_NATIVE \
$OCAMLBUILD_NATIVE $OCAMLDOC_NATIVE $CAMLP4_NATIVE
$OCAMLBUILD_NATIVE $OCAMLDOC_NATIVE

2
build/world.byte.sh
View File

@ -18,4 +18,4 @@ cd `dirname $0`/..
set -x
$OCAMLBUILD $@ \
$STDLIB_BYTE $OCAMLC_BYTE $OCAMLLEX_BYTE $OCAMLOPT_BYTE $TOPLEVEL $TOOLS_BYTE \
$OTHERLIBS_BYTE $OCAMLBUILD_BYTE $DEBUGGER $OCAMLDOC_BYTE $CAMLP4_BYTE
$OTHERLIBS_BYTE $OCAMLBUILD_BYTE $DEBUGGER $OCAMLDOC_BYTE

2
build/world.native.sh
View File

@ -19,4 +19,4 @@ set -x
$OCAMLBUILD $@ \
$STDLIB_NATIVE $OCAMLC_NATIVE $OCAMLOPT_NATIVE \
$OCAMLLEX_NATIVE $TOOLS_NATIVE $OTHERLIBS_NATIVE \
$OCAMLBUILD_NATIVE $OCAMLDOC_NATIVE $CAMLP4_NATIVE
$OCAMLBUILD_NATIVE $OCAMLDOC_NATIVE

2
camlp4/.ignore
View File

@ -1,2 +0,0 @@
.cache-status
*.tmp.ml

898
camlp4/CHANGES
View File

@ -1,898 +0,0 @@
- [...]
In the revised syntax of parsers the "?" is now a "??" like in the orignal
syntax to not conflict with optional labels.
- [29 Jun 05] Add private row types. Make "private" a type constructor
"TyPrv" rather than a flag. (Jacques)
- [09 Jun 04] Moved "-no_quot" option from pa_o to camlp4, enabling to
use it indepently fom pa_o.cmo.
- [17 Nov 04] Renamed "loc" into "_loc", introducing an incompatibility
with existing code (3.08.x and before). Such code can generally run
unmodified using the -loc option (camlp4 -loc "loc").
Camlp4 Version 3.08.2
------------------------
- [07 Oct 04] Changes in the interfaces plexer.mli and pcaml.mli:
- plexer.mli: introduced a new lexer building function `make_lexer',
similar to `gmake', but returning a triple of references in addition
(holding respectively the character number of the beginning of the
current line, the current line number and the name of the file being
parsed).
- pcaml.mli: a new value `position'. A global reference to a triple like
the one mentioned above.
- [07 Sep 04] Camlp4 grammars `error recovery mode' now issues a warning
when used (but this warning is disabled by default).
Camlp4 Version 3.08.[01]
------------------------
- [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
slightly changes the interface of a few Camlp4 modules (see ICHANGES).
** Warning: Some contribs of the camlp4 distribution are broken because
of this change. In particular the scheme/lisp syntaxes.
- [20 nov 03] Illegal escape sequences in strings now issue a warning.
Camlp4 Version 3.07
___________________
- [29 Sep 03] Camlp4 code now licensed under the LGPL minus clause 6.
- [09 Sep 03] Added tokens LABEL and OPTLABEL in plexer, and use them in
both parsers (ocaml and revised). There was, afaik, no other way to fix
ambiguities (bugs) in parsing labels and type constraints.
Camlp4 Version 3.07 beta1
________________________
- [July 03] Updated the ocaml/camlp4 CVS tree with the camlp4
"parallel" CVS tree, which becomes obsolete from now on.
Added support for recursive modules, private data constructors, and
new syntaxes for integers (int32, nativeint, ...).
Camlp4 Version 3.06++
-----------------------
- [02 Dec 02] In AST predefined quotation, changed antiquotations for
"rec", "mutable": now all are with coercion "opt": $opt:...$ (instead
of "rec" and "mut"). Added antiquotation for "private". Cleaned up
the entries for "methods" and for labelled and optional parameters.
- [29 Nov 02] Removed all "extract_crc" stuff no more necessary with
the new interface of Dynlink.
- [26 Nov 02] Added ability to use "#use" directives in compiled files.
- [21 Nov 02] Changed Scheme syntax for directives: now, e.g. #load "file"
is written: # (load "file"). Added directives in "implem", "interf" and
"use" directive.
- [20 Nov 02] Added Grammar.glexer returning the lexer used by a
grammar. Also added a field in Token.glexer type to ask lexers to
record the locations of the comments.
- [04 Nov 02] Added option -no_quot with normal syntax (pa_o.cmo):
don't parse quotations (it allows to use e.g. <:> as a valid token).
- [31 Oct 02] Added pa_macro.cmo (to replace pa_ifdef.cmo which is
kept for compatibility, but deprecated). The extended statements
allow de definitions of macros and conditional compilation like
in C.
- [29 Oct 02] Changed pretty printers of the three main syntaxes: if
the locations of input are not correct, do no more raise End_of_file
when displaying the inter-phrases (return: the input found up to eof
if not empty, otherwise the value of the -sep parameter if not empty,
otherwise the string "\n").
- [25 Oct 02] Added option -records in pa_sml.cmo: generates normal
OCaml records instead of objects (the user must be sure that there
are no names conflicts).
- [22 Oct 02] Added Plexer.specific_space_dot: when set to "true", the
next call to Plexer.gmake returns a lexer where the dot preceded by
spaces (space, tab, newline, etc.) return a different token than when
not preceded by spaces.
- [19 Oct 02] Added printer in Scheme syntax: pr_scheme.cmo and the
extension pr_schemep.cmo which rebuilts parsers.
- [15 Oct 02] Now, in case of syntax error, the real input file name is
displayed (can be different from the input file, because of the possibility
of line directives, typically generated by /lib/cpp).
Changed interface of Stdpp.line_of_loc: now return also a string: the name
of the real input file name.
- [14 Oct 02] Fixed bug in normal syntax (pa_o.cmo): the constructors
with currification of parameters (C x y) were accepted.
- [14 Oct 02] Fixed many problems of make under Windows (in particular if
installations directories contain spaces).
- [11 Oct 02] In ocaml syntax (pa_o.cmo), fixed 3 bugs (or incompatibilities
with the ocaml yacc version of the compiler): 1/ "ref new foo" was
interpreted as "ref;; new foo" instead of "ref (new foo)" 2/ unary
minuses did not work correctly (nor in quotation of syntax trees), in
particular "-0.0" 3/ "begin end" was a syntax error, instead of being "()".
- [Sep-Oct 02] Many changes and improvements in Scheme syntax.
- [07 Oct 02] Added definition of Pcaml.type_declaration which is
now visible in the interface, allowing to change the type declarations.
- [07 Oct 02] Added Pcaml.syntax_name to allow syntax extensions to test
it and take different decision. In revised syntax, its value is "Revised",
in normal syntax "OCaml" and in Scheme syntax "Scheme".
- [03 Oct 02] Added lexing of '\xHH' where HH is hexadecimal number.
- [01 Oct 02] In normal syntax (camlp4o), fixed problem of lexing
comment: (* bleble'''*)
- [23 Sep 02] Fixed bug: input "0x" raised Failure "int_of_string"
without location (syntaxes pa_o and pa_r).
- [14 Sep 02] Added functions Grammar.iter_entry and Grammar.fold_entry
to iterate a grammar entry and transitively all the entries it calls.
- [12 Sep 02] Added "Pcaml.rename_id", a hook to allow parsers to give
ability to rename their identifiers. Called in Scheme syntax (pa_scheme.ml)
when generating its identifiers.
- [09 Sep 02] Fixed bug under toplevel, the command:
!Toploop.parse_toplevel_phrase (Lexing.from_buff "1;;");;
failed "End_of_file".
- [06 Sep 02] Added "Pcaml.string_of". Combined with Pcaml.pr_expr,
Pcaml.pr_patt, and so on, allow to pretty print syntax trees in string.
E.g. in the toplevel:
# #load "pr_o.cmo";
# Pcaml.string_of Pcaml.pr_expr <:expr< let x = 3 in x + 2 >>;;
- : string = "let x = 3 in x + 2"
Camlp4 Version 3.06
--------------------
- [24 Jul 02] Added Scheme syntax: pa_scheme.ml, camlp4sch.cma (toplevel),
camlp4sch (command).
Camlp4 Version 3.05
-----------------------
- [12 Jul 02] Better treatment of comments in option -cip (add comments
in phrases) for both printers pr_o.cmo (normal syntax) and pr_r.cmo
(revised syntax); added comments before let binding and class
structure items; treat comments inside sum and record type definitions;
the option -tc is now deprecated and equivalent to -cip.
- [13 Jun 02] Added pa_lefteval.cmo: add let..in expressions to guarantee
left evaluation of functions parameters, t-uples, and so on (instead of
the default non-specified-but-in-fact-right-to-left evaluation).
- [06 Jun 02] Changed revised syntax (pa_r) of variants types definition;
(Jacques Garrigue's idea):
old syntax new syntax
[| ... |] [ = ... ]
[| < ... |] [ < ... ]
[| > ... |] [ > ... ]
This applies also in predefined quotations of syntax tree for types
<:ctyp< ... >>
- [05 Jun 02] Added option -ss in pr_o.cmo: print with double semicolons;
and the option -no_ss is now by default.
- [30 May 02] Improved SML syntax (pa_sml).
- [30 May 02] Changed the AST for the "with module" construct (was with
type "module_type"; changed into type "module_expr").
- [26 May 02] Added missing abstract module types.
- [21 Apr 02] Added polymorphic types for polymorphic methods:
revised syntax (example): ! 'a 'b . type
ctyp quotation: <:ctyp< ! $list:pl$ . $t$ >>
- [17 Apr 02] Fixed bug: in normal syntax (pa_o.cmo) made a parse error on
the "dot" on (in interface file file):
class c : a * B.c -> object val x : int end
- [03 Apr 02] Fixed bug: (* "(*" *) resulted in "comment not terminated".
- [03 Apr 02] Fixed incompatibility with ocaml: ''' and '"' must be
displayed as '\'' and '\"' in normal syntax printer (pr_o.cmo).
- [03 Apr 02] When there are several tokens parsed together (locally LL(n)),
the location error now highlights all tokens, resulting in a more clear
error message (e.g. "for i let" would display "illegal begin of expr"
and highlight the 3 tokens, not just "for").
- [30 Mar 02] Added pa_extfold.cmo extending pa_extend.cmo by grammar
symbols FOLD0 and FOLD1. Work like LIST0 and LIST1 but have two initial
parameters: a function of type 'a -> 'b -> 'b doing the fold and an
initial value of type 'b. Actually, LIST0 now is like
FOLD0 (fun x y -> x :: y) []
with an reverse of the resulting list.
- [20 Mar 02] Fixed problem: when running a toplevel linked with camlp4
as a script, the camlp4 welcome message was displayed.
- [14 Mar 02] The configure shell and the program now test the consistency
of OCaml and Camlp4. Therefore 1/ if trying to compile this version with
an incompatible OCaml version or 2/ trying to run an installed Camlp4 with
a incompatible OCaml version: in both cases, camlp4 fails.
- [14 Mar 02] When make opt.opt is done, the very fast version is made for
the normal syntax ("compiled" version). The installed camlp4o.opt is that
version.
- [05 Mar 02] Changed the conversion to OCaml syntax tree for <:expr< x.val >>
and <:expr< x.val := e >> which generates now the tree of !x and x := e,
no more x.contents and x.contents <- e. This change was necessary because
of a problem if a record has been defined with a field named "contents".
- [16 Feb 02] Changed interface of grammars: the token type is now
customizable, using a new lexer type Token.glexer, parametrized by
the token type, and a new functor GMake. This was accompanied by
some cleanup. Become deprecated: the type Token.lexer (use Token.glexer),
Grammar.create (use Grammar.gcreate), Unsafe.reinit_gram (use
Unsafe.gram_reinit), the functor Grammar.Make (use Grammar.GMake).
Deprecated means that they are kept during some versions and removed
afterwards.
- [06 Feb 02] Added missing infix "%" in pa_o (normal syntax).
- [06 Feb 02] Added Grammar.print_entry printing any kind of (obj) entry
and having the Format.formatter as first parameter (Grammar.Entry.print
and its equivalent in functorial interface call it).
- [05 Feb 02] Added a flag Plexer.no_quotations. When set to True, the
quotations are no more lexed in all lexers built by Plexer.make ()
- [05 Feb 02] Changed the printing of options so that the option -help
aligns correctly their documentation. One can use now Pcaml.add_option
without having to calculate that.
- [05 Feb 02] pr_r.cmo: now the option -ncip (no comments in phrases) is
by default, because its behaviour is not 100% sure. An option -cip has
been added to set it.
- [03 Feb 02] Added function Stdpp.line_of_loc returning the line and
columns positions from a character location and a file.
- [01 Feb 02] Fixed bug in token.ml: the location function provided by
lexer_func_of_parser, lexer_func_of_ocamllex and make_stream_and_location
could raise Invalid_argument "Array.make" for big files if the number
of read tokens overflows the maximum arrays size (Sys.max_array_length).
The bug is not really fixed: in case of this overflow, the returned
location is (0, 0) (but the program does not fail).
- [28 Jan 02] Fixed bug in pa_o when parsing class_types. A horrible hack
had to be programmed to be able to treat them correctly.
- [28 Jan 02] Fixed bug in OCaml toplevel when loading camlp4: the directives
were not applied in the good order.
- [26 Jan 02] The printer pr_extend.cmo try now also to rebuild GEXTEND
statements (before it tried only the EXTEND).
- [23 Jan 02] The empty functional stream "fstream [: :]" is now of type
'a Fstream.t thanks to the new implementation of lazies allowing to
create polymorphic lazy values.
- [11 Jan 02] Added a test in grammars using Plexer that a keyword is not
used also as parameter of a LIDENT or a UIDENT.
- [04 Jan 02] Fixed bug in pa_sml (SML syntax): the function definitions
with several currified parameters did not work. It works now, but the
previous code was supposed to treat let ("fun" in SML syntax) definitions
of infix operators, what does not work any more now.
- [04 Jan 02] Alain Frisch's contribution:
Added pa_ocamllex.cma, syntax for ocamllex files. The command:
camlp4 pa_ocamllex.cmo pr_o.cmo -ocamllex -impl foo.mll > foo.ml
does the same thing as:
ocamllex foo.mll
Allow to compile directly mll files. Without option -ocamllex, allow
to insert lex rules in a ml file.
- [29 Dec 01] Added variable "inter_phrases" in Pcaml, of type ref (option
string) to specify the string to print between phrases in pretty printers.
The default is None, meaning to copy the inter phrases from the source
file.
Camlp4 Version 3.04
-------------------
- [07 Dec 01] Added Pcaml.parse_interf and Pcaml.parse_implem, hooks to
specify the parsers tof use, i.e. now can use other parsing technics
than the Camlp4 grammar system.
- [27 Nov 01] Fixed functions Token.eval_char and Token.eval_string which
returned bad values, resulting lexing of backslash sequences incompatible
with OCaml (e.g. "\1" returned "\001" (one character) but OCaml returns
the string of the two characters \ and 1).
- [15 Nov 01] In revised syntax, in let binding in sequences, the "in"
can be replaced by a semicolon; the revised syntax printer pr_r.cmo
now rather prints a semicolon there.
- [07 Nov 01] Added the ability to use $ as token: was impossible so far,
because of AST quotation uses it for its antiquotation. The fix is just
a little (invisible) change in Plexer.
- [05 Nov 01] Added option -tc (types comment) when using pr_o or pr_r
try to print comments inside sum and record types like they are in
the source (not by default, because may work incorrectly).
- [05 Nov 01] Added option -ca (comment after) when using pr_o or pr_r:
print ocamldoc comments after the declarations, when they are before.
- [04 Nov 01] Added locations for variants and labels declarations in AST
(file MLast.mli).
- [03 Nov 01] In pretty printers pr_o and pr_r, skip to next begin of line
when displaying the sources between phrase, to prevent e.g. the displaying
of the possible last comment of a sum type declaration (the other comment
being not displayed anyway).
- [24 Oct 01] Fixed incorrect locations in sequences.
- [24 Oct 01] Was erroneously compiled by the OCaml boot compiler instead
of the generated ocamlc. Fixed.
- [15 Oct 01] Fixed some parsing differences between pa_o and ocamlyacc:
in parsers, in labels.
- [12 Oct 01] Added missing bigarray syntax a.{b} (and Cie) in standard
syntax (pa_o).
Camlp4 Version 3.03
-------------------
- [09 Oct 01] Fixed bug: the token !$ did not work. Fixed and completed
some syntaxes of labels patterns. Added missing case in exception
declaration (exception rebinding).
- [05 Oct 01] Fixed bug in normal syntax: when defining a constructor
named "True" of "False" (capitalized, i.e. not like the booleans), it
did not work.
- [04 Oct 01] Fixed some revised and quotation syntaxes in objects classes
and types (cleaner). Cleaned up also several parts of the parsers.
- [02 Oct 01] In revised syntax, the warning for using old syntax for
sequences is now by default. To remove it, the option -no-warn-seq
of camlp4r has been added. Option -warn-seq has been removed.
- [07 Sep 01] Included Camlp4 in OCaml distribution.
- [06 Sep 01] Added missing pattern construction #t
- [05 Sep 01] Fixed bug in pa_o: {A.B.c = d} was refused.
- [26 Aug 01] Fixed bug: in normal and revised syntaxes, refused -1.0
(minus float) as pattern.
- [24 Aug 01] Fixed bug: (a : b :> c) and ((a : b) :> c) were parsed
identically.
- [20 Aug 01] Fixed configure script for Windows configuration.
- [10 Aug 01] Fixed bug: <:expr< 'a' >> did not work because of a typing
problem.
- [10 Aug 01] Fixed bug in compilation process under Windows: the use of
the extension .exe was missing in several parts in Makefiles and shell
scripts.
- [09 Aug 01] Changed message error in grammar: in the case when the rule
is: ....; tok1; tok2; .. tokn; ... (n terminal tokens following each other),
where the grammar is locally LL(n), it displays now:
tok1 tok2 .. tokn expected
instead of just
tok1 expected
because "tok1" can be correct in the input, and in this case, the message
underscored the tok1 and said "tok1 expected".
- [07 Aug 01] When camlp4r.cma is loaded in the toplevel, the results are
now displayed in revised syntax.
- [04 Aug 01] Added syntax "declare..end" in quotations class_str_item and
class_sig_item to be able to generate several items from one only item
(like in str_item and sig_item).
Camlp4 Version 3.02
-------------------
- [21 Jul 01] Fixed bug: <:expr< { l = x } >> was badly built and resulted
in a typing error.
- [13 Jul 01] Fixed bug: did not accept floats in patterns.
- [11 Jul 01] Added function Pcaml.top_printer to be able to use the
printers Pcaml.pr_expr, Pcaml.pr_patt, and so on for the #install_printer
of OCaml toplevel. Ex:
let f = Pcaml.top_printer Pcaml.pr_expr;;
#install_printer f;;
#load "pr_o.cmo";;
- [24 Jun 01] In grammars, added symbol ANY, returning the current token,
whichever it is.
- [24 Jun 01] In grammars, a rule list of the form [ s1 | s2 | .. | sn ]
is interpreted as [ x = s1 -> x | x = s2 -> x | .. x = sn -> x ]
instead of [ _ = s1 -> () | _ = s2 -> () .. ]
- [24 Jun 01] Moved the functions [Plexer.char_of_char_token] and
[Plexer.string_of_string_token] into module [Token] with names
[Token.eval_char] and [Token.eval_string].
- [22 Jun 01] Added warning when using old syntax for sequences, while
and do (do..return, do..done) in predefined quotation expr.
- [22 Jun 01] Changed message for unbound quotations (more clear).
Camlp4 Version 3.01.6:
----------------------
- [22 Jun 01] Changed the module Pretty into Spretty.
- [21 Jun 01] Camlp4 can now be compiled even if OCaml is not installed:
in the directory "config", the file "configure_batch" is a possibility
to configure the compilation (alternative of "configure" of the top
directory) and has a parameter "-ocaml-top" to specify the OCaml top
directory (relative to the camlp4/config directory).
- [21 Jun 01] The interactive "configure" now tests if the native-code
compilers ocamlc.opt and ocamlopt.opt are accessible and tell the
Makefile to preferably use them if they are.
- [16 Jun 01] The syntax tree for strings and characters now represent their
exact input representation (the node for characters is now of type string,
no more char). For example, the string "a\098c" remains "a\098c" and is
*not* converted into (the equivalent) "abc" in the syntax tree. The
convertion takes place when converting into OCaml tree representation.
This has the advantage that the pretty print now display them as they
are in the input file. To convert from input to real representation
(if needed), two functions have been added: Plexer.string_of_string_token
and Plexer.char_of_char_token.
- [10 Jun 01] In revised syntax, added ability to write {foo x = y} as short
form for {foo = fun x -> y}.
- [08 Jun 01] Completed missing cases in pa_extfun.cmo for variants.
- [06 Jun 01] Completed missing cases in abstract syntax tree and in normal
syntax parser pa_o.ml (about classes).
- [06 Jun 01] Fixed bug in pa_o.cmo (parser of normal syntax): (~~) did not
work, and actually all prefix operators between parentheses.
Camlp4 Version 3.01.5:
----------------------
- [04 Jun 01] Fixed bug: when using "include" in a structure item the rest
of the structure was lost.
- [31 May 01] Added ability to user #load and #directory inside ml or mli
files to specify a cmo file to be loaded (for syntax extension) or the
directory path (like option -I). Same semantics than in toplevel.
- [29 May 01] The name of the location variable used in grammars (action
parts of the rules) and in the predefined quotations for OCaml syntax
trees is now configurable in Stdpp.loc_name (string reference). Added also
option -loc to set this variable. Default: loc.
- [26 May 01] Added functional streams: a library module Fstream and a syntax
kit: pa_fstream.cmo. Syntax:
streams: fstream [: ... :]
parsers: fparser [ [: ... :] -> ... | ... ]
- [25 May 01] Added function Token.lexer_func_of a little bit more general
than Token.lexer_func_of_parser.
Camlp4 Version 3.01.4:
----------------------
- [20 May 01] Fixed bug: pr_rp and pr_op could generate bound variables
resulting incorrect program:
(e.g. fun s -> parser [: `_; x :] -> s x was printed:
fun s -> parser [: `_; s :] -> s s)
- [19 May 01] Small improvement in pretty.ml resulting a faster print (no
more stacked HOVboxes which printers pr_r and pr_o usually generate in
expr, patt, ctyp, etc.)
- [18 May 01] Added [lexer_func_of_parser] and [lexer_func_of_ocamllex]
in module [Token] to create lexers functions from char stream parsers
or from [ocamllex] lexers.
- [16 May 01] Pretty printing with pr_r.cmo (revised syntax) now keep
comments inside phrases.
- [15 May 01] Changed pretty printing system, using now new extensible
functions of Camlp4.
- [15 May 01] Added library module Extfun for extensible functions,
syntax pa_extfun, and a printer pr_extfun.
- [12 May 01] Fixed bug: missing cases in pr_o and pr_r for in cases of
"for", "while", and some other expressions, when between parentheses.
Camlp4 Version 3.01.3:
----------------------
- [04 May 01] Put back the syntax "do ... return ..." in predefined
quotation "expr", to be able to compile previous programs. Work
only if the quotation is in position of expression, not in pattern.
- [04 May 01] Added lisp syntax pa_lisp.cmo (not terminated).
- [01 May 01] Fixed bug: in toplevel, in case of syntax error in #use,
the display was incorrect: it displayed the input, instead of the
file location.
Camlp4 Version 3.01.2:
----------------------
- [27 Apr 01] Added variable Grammar.error_verbose and option -verbose of
command camlp4 to display more information in case of parsing error.
- [27 Apr 01] Fixed bug: the locations in sequences was not what expected
by OCaml, resulting on bad locations displaying in case of typing error.
- [27 Apr 01] Fixed bug: in normal syntax, the sequence was parsed
of left associative instead of right associative, resulting bad pretty
printing.
Camlp4 Version 3.01.1:
----------------------
- [19 Apr 01] Added missing new feature "include" (structure item).
- [17 Apr 01] Changed revised syntax of sequences. Now:
do { expr1; expr2 ..... ; exprn }
for patt = expr to/downto expr do { expr1; expr2 ..... ; exprn }
while expr do { expr1; expr2 ..... ; exprn }
* If holding a "let ... in", the scope applies up to the end of the sequence.
* The old syntax "do .... return ..." is still accepted.
* In expr quotation, it is *not* accepted. To ensure backward
compatibility, use ifdef NEWSEQ, which answers True from this version.
* The printer pr_r.cmo by default prints with this new syntax.
* To print with old syntax, use option -old_seq.
* To get a warning when using old syntax, use option -warn_seq.
Camlp4 Version 3.01:
--------------------
- [5 Mar 01] In pa_o.ml fixed problem, did not parse:
class ['a, 'b] cl a b : ['a, 'b] classtype
- [9 Oct 00] Raise now Stream.Error when parsing with an empty entry (meaning
that the user probably forgot to initialize it).
- [21 Jul 00] Fixed (pr_o.cmo) pb of bad printing of
let (f : unit -> int) = fun () -> 1
- [10 Jun, 21 Jul 00] Added Pcaml.sync to synchronize after syntax error in
toplevel.
- [24 May 00] Changed the "make opt", returning to what was done in the
previous releases, i.e. just the compilation of the library (6 files).
The native code compilation of "camlp4o" and "camlp4r" are not absolutely
necessary and can create problems in some systems because of too long code.
The drawbacks are more important than the advantages.
- [19 May 00] Changed option -split_gext (when pa_extend.cmo is loaded) into
-split_ext: it applies now also for non functorial grammars (extended by
EXTEND instead of GEXTEND).
- [12 May 00] Fixed problem in pr_rp.cmo and pr_op.cmo: the pretty printing
of the construction "match x with parser" did not work (because of the
type constraint "Stream.t _" added some versions ago).
Camlp4 Version 3.00:
--------------------
- [Apr 19, 00] Added "pa_olabl" for labels with old Olabl syntax.
- [Apr 18, 00] Make opt now builds camlp4o.opt and camlp4r.opt
- [Apr 17, 00] Added support for labels and variants.
- [Mar 28, 00] Improved the grammars: now the rules starting with n
terminals are locally LL(n), i.e. if any of the terminal fails, it is
not Error but just Failure. Allows to write the OCaml syntax case:
( operator )
( expr )
with the problem of "( - )" as:
"("; "-"; ")"
"("; operator; ")"
"("; expr; ")"
after factorization of the "(", the rule "-"; ")" is locally LL(2): it
works for this reason. In the previous implementation, a hack had to be
added for this case.
To allow this, the interface of "Token" changed. The field "tparse" is
now of type "pattern -> option (Stream.t t -> string)" instead of
"pattern -> Stream.t t -> string". Set it to "None" for standard pattern
parsing (or if you don't know).
Camlp4 Version 2.04:
--------------------
- [Nov 23, 99] Changed the module name Config into Oconfig, because of
conflict problem when applications want to link with the module Config of
OCaml.
Camlp4 Version 2.03:
--------------------
* pr_depend:
- [Jun 25, 99] Added missing case in "pr_depend.cmo": pattern A.B.C.
- [Jun 5, 99] Fixed in "pr_depend.ml" case expression "Foo.Bar" displaying a
bad dependency with file "bar.ml" if existed. And changed "pa_r.ml"
(revised syntax parsing) to generate a more logical ast for case
"var.Mod.lab".
- [Apr 29, 99] Added missing cases in "pr_o.cmo" and in "pr_depend.cmo".
- [Mar 11, 99] Added missing cases in "pr_depend.cmo".
- [Mar 9, 99] Added missing case in pr_depend.ml.
* Other:
- [Sep 10, 99] Updated from current OCaml new interfaces.
- [Jul 9, 99] Added stream type constraint in pa_oop.ml to reflect the same
change in OCaml.
- [Jun 24, 99] Added missing "constraint" construction in types
- [Jun 15, 99] Added option -I for command "mkcamlp4".
- [May 14, 99] Added man pages (links) for camlp4o, camlp4r, mkcamlp4, ocpp
- [May 10, 99] Added shell script "configure_batch" in directory "config".
- [May 10, 99] Changed LICENSE to BSD.
- [Apr 29, 99] Added "ifdef" for mli files.
- [Apr 11, 99] Changed option "-no_cp" into "-sep" in pr_r.cmo and pr_o.cmo.
- [Apr 11, 99] Fixed (old) bug: too long strings where bad pretty printed.
- [Mar 24, 99] Added missing stream type constraint for parsers.
- [Mar 17, 99] Changed template Makefile to use ocamlc.opt and ocamlopt.opt
by default, instead of ocamlc and ocamlopt.
- [Mar 9, 99] Added ifndef in pa_ifdef.ml.
- [Mar 7, 99] Completed and fixed some cases in pr_extend.ml.
Camlp4 Version 2.02:
--------------------
* Parsing:
- [Feb 27, 99] Fixed 2 bugs, resulting of incorrect OCaml parsing of the
program example: "type t = F(B).t"
- [Jan 30, 99] Fixed bug "pa_op.ml", could not parse "parser | [<>] -> ()".
- [Jan 16, 99] Added "define" and "undef" in "pa_ifdef.cmo".
- [Dec 22, 98] Fixed precedence of "!=" in OCaml syntax
* Printing:
- [Mar 4, 99] Added pr_depend.cmo for printing file dependencies.
- [Dec 28, 98] Fixed pretty printing of long strings starting with spaces;
used to display "\\n<spaces>..." instead of "<spaces>\\n...".
* Camlp4:
- [Feb 19, 99] Sort command line argument list in reverse order to
avoid argument names conflicts when adding arguments.
* Olabl:
- [Feb 26, 99] Started extensions for Olabl: directory "lablp4" and some
changes in MLast. Olabl programs can be preprocessed by:
camlp4 pa_labl.cma pr_ldump.cmo
* Internal:
- Use of pr_depend.cmo instead of ocamldep for dependencies.
Camlp4 Version 2.01:
--------------------
Token interface
* Big change: the type for tokens and tokens patterns is now (string * string)
the first string being the constructor name and the second its possible
parameters. No change in EXTEND statements using Plexer. But lexers
have:
- a supplementary parameter "tparse" to specify how to parse token
from token patterns.
- fields "using" and "removing" replacing "add_keyword" and
"remove_keyword".
See the file README-2.01 for how to update your programs and the interface
of Token.
Grammar interface
* The function "keywords" have been replaced by "tokens". The equivalent
of the old statement:
Grammar.keywords g
is now:
Grammar.tokens g ""
Missing features added
* Added "lazy" statement (pa_r.cmo, pa_o.cmo, pr_r.cmo, pr_o.cmo)
* Added print "assert" statement (pr_o.cmo, pr_r.cmo)
* Added parsing of infix operators like in OCaml (e.g. |||) in pa_o.cmo
Compilation
* Added "make scratch"
* Changed Makefile. No more "make T=../", working bad in some systems.
* Some changes to make compilation in Windows 95/98 working better (thanks
to Patricia Peratto).
Classes and objects
* Added quotations for classes and objects (q_MLast.ml)
* Added accessible entries in module Pcaml (class_type, class_expr, etc.)
* Changed classes and objects types in definition (module MLast)
Miscelleneous
* Some adds in pa_sml.cmo. Thanks to Franklin Chen.
* Added option "-no_cp" when "pr_o.cmo" or "pr_r.cmo" is loaded: do
not print comments between phrases.
* Added option "-split_gext" when "pa_extend.cmo" is loaded: split GEXTEND
by functions to turn around a PowerPC problem.
Bug fixes
* Fixed pa_r.cmo, pa_o.cmo to parse, and pr_r.cmo, pr_o.cmo to print "(x:#M.c)"
* Fixed printing pr_o.cmo of "(a.b <- 1)::1"
* Extended options with parameters worked only when the parameter was sticked.
Ex:
camlp4o pr_o.cmo -l120 foo.ml
worked, but not:
camlp4o pr_o.cmo -l 120 foo.ml
Camlp4 Version 2.00:
--------------------
* Designation "righteous" has been renamed "revised".
* Added class and objects in OCaml printing (pr_o.cmo), revised parsing
(pa_r.cmo) and printing (pr_r.cmo).
* Fixed bug in OCaml syntax: let _, x = 1, 2;; was refused.
Camlp4 Version 2.00--1:
-----------------------
* Added classes and objects in OCaml syntax (pa_o.cmo)
* Fixed pr_r.cmo et pr_r.cmo which wrote on stdout, even when option -o
Camlp4 Version 2.00--:
----------------------
* Adapted for OCaml 2.00.
* No objects and classes in this version.
* Added "let module" parsing and printing.
* Added arrays patterns parsing and printing.
* Added records with "with" "{... with ...}" parsing and printing
* Added # num "string" in plexer (was missing).
* Fixed bug in pr_o.cmo: module A = B (C);; was printed module A = B C;;
* Added "pa_sml.cmo", SML syntax + "lib.sml"
* Fixed bug in pa_r.ml and pa_o.ml: forgot to clear let_binding
* Changed Plexer: unknown keywords do not raise error but return Tterm
* q_MLast.cmo: suppressed <:expr< [$list:el$] >> (cannot work)
* Added option "-no_ss" (no ;;) when "pr_o.cmo" loaded
* Many changes and bug fixing in pretty printing pr_o.cmo and pr_r.cmo
* Command ocpp works now without having to explicitely load
"/usr/local/lib/ocaml/stdlib.cma" and
"/usr/local/lib/camlp4/gramlib.cma"
* Fixed problem of pretty print "&" and "or" in normal and righteous syntaxes
* Added missing statement "include" in signature item in normal and righteous
syntaxes
* Changed precedence of ":=" and "<-" in normal syntax (pa_o et pr_o):
now before "or", like in OCaml compiler.
* Same change in righteous syntax, by symmetry.
Camlp4 Version 1.07.2:
----------------------
Errors and missings in normal and righteous syntaxes.
* Added forgotten syntax (righteous): type constraints in class type fields.
* Added missing syntax (normal): type foo = bar = {......}
* Added missing syntax (normal): did not accept separators before ending
constructions (many of them).
* Fixed bug: "assert false" is now of type 'a, like in OCaml.
* Fixed to match OCaml feature: "\^" is "\^" in OCaml, but just "^" in Camlp4.
* Fixed bug in Windows NT/95: problem in backslash before newlines in strings
Grammars, EXTEND, DELETE_RULE
* Added functorial version for grammars (started in version 1.07.1,
completed in this version).
* Added statements GEXTEND and GDELETE_RULE in pa_extend.cmo for functorial
version.
* EXTEND statement is added AFTER "top" instead of LEVEL "top" (because
of problems parsing "a; EXTEND...")
* Added ability to have expressions (in antiquotation form) of type string in
EXTEND after keywords "LIDENT", "UIDENT", "IDENT", "ANTIQUOT", "INT" as
in others constructions inside EXTEND.
* A grammar rule hidden by another is not deleted but just masked. DELETE_RULE
will restore the old version.
* DELETE_RULE now raises Not_found if no rule matched.
* Fixed bug: DELETE_RULE did not work when deleting a rule which is a prefix of
another rule.
* Some functions for "system use" in [Grammar] become "official":
[Entry.obj], [extend], [delete_rule].
Command line, man page
* Added option -o: output on file instead of standard output, necessary
to allow compilation in Windows NT/95 (in fact, this option exists since
1.07.1 but forgotten in its "changes" list).
* Command line option -help more complete.
* Updated man page: camlp4 options are better explained.
* Fixed bug: "camlp4 [other-options] foo.ml" worked but not
"camlp4 foo.ml [other-options]".
* Fixed bug: "camlp4 foo" did not display a understandable error message.
Camlp4's compilation
* Changes in compilation process in order to try to make it work better for
Windows NT under Cygnus.
Miscellaneous
* Added [Pcaml.add_option] for adding command line options.
Camlp4 Version 1.07.1:
----------------------
* Added forgotten syntax in pr_o: type x = y = A | B
* Fixed bug negative floats parsing in pa_o => error while pretty printing
* Added assert statement and option -noassert.
* Environment variable CAMLP4LIB to change camlp4 library directory
* Grammar: empty rules have a correct location instead of (-1, -1)
* Compilation possible in Windows NT/95
* String constants no more shared while parsing OCaml
* Fixed bug in antiquotations in q_MLast.cmo (bad errors locations)
* Fixed bug in antiquotations in q_MLast.cmo (EOI not checked)
* Fixed bug in Plexer: could not create keywords with iso 8859 characters
Camlp4 Version 1.07:
--------------------
* Changed version number + configuration script
* Added iso 8859 uppercase characters for uidents in plexer.ml
* Fixed bug factorization IDENT in grammars
* Fixed bug pr_o.cmo was printing "declare"
* Fixed bug constructor arity in OCaml syntax (pa_o.cmo).
* Changed "lazy" into "slazy".
* Completed pa_ifdef.cmo.
Camlp4 Version 1.06:
--------------------
* Adapted to OCaml 1.06.
* Changed version number to match OCaml's => 1.06 too.
* Deleted module Gstream, using OCaml's Stream.
* Generate different AST for C(x,y) and C x y (change done in OCaml's compiler)
* No more message "Interrupted" in toplevel in case of syntax error.
* Added flag to suppress warnings while extending grammars.
* Completed some missing statements and declarations (objects)
* Modified odyl implementation; works better
* Added ability to extend command line specification
* Added "let_binding" as predefined (accessible) entry in Pcaml.
* Added construction FUNCTION in EXTEND statement to call another function.
* Added some ISO-8859-1 characters in lexer identifiers.
* Fixed bug "value x = {val = 1};" (righteous syntax)
* Fixed bug "open A.B.C" was interpreted as "open B.A.C"
* Modified behavior of "DELETE_RULE": the complete rule must be provided
* Completed quotations MLast ("expr", "patt", etc) to accept whole language
* Renamed "LIKE" into "LEVEL" in grammar EXTEND
* Added "NEXT" as grammar symbol in grammar EXTEND
* Added command "mkcamlp4" to make camlp4 executables linked with C code
* Added "pr_extend.cmo" to reconstitute EXTEND instructions
Camlp4 Version 0.6:
-------------------
--- Installing
* To compile camlp4, it is no more necessary to have the sources of the
Objective Caml compiler available. It can be compiled like any other
Objective Caml program.
--- Options of "camlp4"
* Added option -where: "camlp4 -where" prints the name of the standard
library directory of Camlp4 and exit. So, the ocaml toplevel and the
compiler can use the option:
-I `camlp4 -where`
* Added option -nolib to not search for objects files in the installed
library directory of Camlp4.
--- Interface of grammar library modules
* The function Grammar.keywords returns now a list of pairs. The pair is
composed of a keyword and the number of times it is used in entries.
* Changed interface of Token and Grammar for lexers, so user lexers have
to be changed.
--- New features in grammars
* New instruction "DELETE_RULE" provided by pa_extend.cmo to delete rules.
Ex:
DELETE_RULE Pcaml.expr: "if" END;
deletes the "if" instruction of the language.
* Added the ability to parse some specific integer in grammars: a possible
parameter to INT, like the ones for LIDENT and UIDENT.
* In instruction EXTEND, ability to omit "-> action", default is "-> ()"
* Ability to add antiquotation (between $'s) as symbol rule, of type string,
interpreted as a keyword, in instruction EXTEND.
* Ability to put entries with qualified names (Foo.bar) in instruction EXTEND.
--- Quotations
* The module Ast has been renamed MLast. The quotation expander "q_ast.cmo"
has been renamed "q_MLast.cmo".
* Quotation expanders are now of two kinds:
- The "classical" type for expanders returning a string. These expanders
have now a supplementary parameter: a boolean value set to "True"
when the quotation is in a context of an expression an to "False"
when the quotation is in a context of a pattern. These expanders,
returning strings which are parsed afterwards, may work for some
language syntax and/or language extensions used (e.g. may work for
Righteous syntax and not for OCaml syntax).
- A new type of expander returning directly syntax trees. A pair
of functions, for expressions and for patterns must be provided.
These expanders are independant from the language syntax and/or
extensions used.
* The predefined quotation expanders "ctyp_", "patt_" and "expr_" has
been deleted; one can use "ctyp", "patt", and "expr" in position of
pattern or expression.
--- OCaml and Righteous syntaxes
* Fixed bug: "open Foo.Bar" was converted (pr_dump.cmo) into "open Bar.Foo"
* Corrected behavior different from OCaml's: "^" and "@" were at the same
level than "=": now, like OCaml, they have a separated right associative
level.
--- Grammars behavior
* While extending entries: default position is now "extension of the
first level", instead of "adding a new level at the end".
* Another Change: in each precedence level, terminals are inserted before
other symbols (non terminals, lists, options, etc), LIDENT "foo" before
LIDENT (alone) and UIDENT "foo" before UIDENT (alone). New rules not
factorizable are now inserted before the other rules.
* Changed algorithm of entries parsing: each precedence level is tested
against the stream *before* its next precedences levels (instead of
*after*):
EXTEND e: [[ LIDENT "a" -> "xxx" ] | [ i = LIDENT -> i ]]; END;
Now, parsing the entry e with the string "a" returns "xxx" instead of "a"
* Less keywords in instruction EXTEND (LEFTA, LIDENT, etc), which can be
used now as normal identifiers.
* When inserting a new rule, a warning appears if a rule with the
same production already existed (it is deleted).
* Parse error messages (Gstream.Error) are formatted => spaces trigger
Format.print_space and newlines trigger Format.force_newline.
Camlp4 Version 0.5:
-------------------
* Possible creation of native code library (make opt)
* OCaml and Righteous Syntax more complete
* Added pa_ru.cmo for compiling sequences of type unit (Righteous)
* Quotations AST
- No more quotation long_id
- Antiquotations for identifiers more simple
* Lot of small changes
Camlp4 Version 0.4:
-------------------
* First distributed version

9
camlp4/Camlp4.mlpack
View File

@ -1,9 +0,0 @@
Debug
ErrorHandler
OCamlInitSyntax
Options
PreCast
Printers
Register
Sig
Struct

421
camlp4/Camlp4/Camlp4Ast.partial.ml
View File

@ -1,421 +0,0 @@
(****************************************************************************)
(* *)
(* OCaml *)
(* *)
(* INRIA Rocquencourt *)
(* *)
(* Copyright 2007 Institut National de Recherche en Informatique et *)
(* en Automatique. All rights reserved. This file is distributed under *)
(* the terms of the GNU Library General Public License, with the special *)
(* exception on linking described in LICENSE at the top of the OCaml *)
(* source tree. *)
(* *)
(****************************************************************************)
(* Note: when you modify these types you must increment
ast magic numbers defined in Camlp4_config.ml. *)
type loc = Loc.t
and meta_bool =
[ BTrue
| BFalse
| BAnt of string ]
and rec_flag =
[ ReRecursive
| ReNil
| ReAnt of string ]
and direction_flag =
[ DiTo
| DiDownto
| DiAnt of string ]
and mutable_flag =
[ MuMutable
| MuNil
| MuAnt of string ]
and private_flag =
[ PrPrivate
| PrNil
| PrAnt of string ]
and virtual_flag =
[ ViVirtual
| ViNil
| ViAnt of string ]
and override_flag =
[ OvOverride
| OvNil
| OvAnt of string ]
and row_var_flag =
[ RvRowVar
| RvNil
| RvAnt of string ]
and meta_option 'a =
[ ONone
| OSome of 'a
| OAnt of string ]
and meta_list 'a =
[ LNil
| LCons of 'a and meta_list 'a
| LAnt of string ]
and ident =
[ IdAcc of loc and ident and ident (* i . i *)
| IdApp of loc and ident and ident (* i i *)
| IdLid of loc and string (* foo *)
| IdUid of loc and string (* Bar *)
| IdAnt of loc and string (* $s$ *) ]
and ctyp =
[ TyNil of loc
| TyAli of loc and ctyp and ctyp (* t as t *) (* list 'a as 'a *)
| TyAny of loc (* _ *)
| TyApp of loc and ctyp and ctyp (* t t *) (* list 'a *)
| TyArr of loc and ctyp and ctyp (* t -> t *) (* int -> string *)
| TyCls of loc and ident (* #i *) (* #point *)
| TyLab of loc and string and ctyp (* ~s:t *)
| TyId of loc and ident (* i *) (* Lazy.t *)
| TyMan of loc and ctyp and ctyp (* t == t *) (* type t = [ A | B ] == Foo.t *)
(* type t 'a 'b 'c = t constraint t = t constraint t = t *)
| TyDcl of loc and string and list ctyp and ctyp and list (ctyp * ctyp)
(* < (t)? (..)? > *) (* < move : int -> 'a .. > as 'a *)
| TyObj of loc and ctyp and row_var_flag
| TyOlb of loc and string and ctyp (* ?s:t *)
| TyPol of loc and ctyp and ctyp (* ! t . t *) (* ! 'a . list 'a -> 'a *)
| TyTypePol of loc and ctyp and ctyp (* type t . t *) (* type a . list a -> a *)
| TyQuo of loc and string (* 's *)
| TyQuP of loc and string (* +'s *)
| TyQuM of loc and string (* -'s *)
| TyAnP of loc (* +_ *)
| TyAnM of loc (* -_ *)
| TyVrn of loc and string (* `s *)
| TyRec of loc and ctyp (* { t } *) (* { foo : int ; bar : mutable string } *)
| TyCol of loc and ctyp and ctyp (* t : t *)
| TySem of loc and ctyp and ctyp (* t; t *)
| TyCom of loc and ctyp and ctyp (* t, t *)
| TySum of loc and ctyp (* [ t ] *) (* [ A of int and string | B ] *)
| TyOf of loc and ctyp and ctyp (* t of t *) (* A of int *)
| TyAnd of loc and ctyp and ctyp (* t and t *)
| TyOr of loc and ctyp and ctyp (* t | t *)
| TyPrv of loc and ctyp (* private t *)
| TyMut of loc and ctyp (* mutable t *)
| TyTup of loc and ctyp (* ( t ) *) (* (int * string) *)
| TySta of loc and ctyp and ctyp (* t * t *)
| TyVrnEq of loc and ctyp (* [ = t ] *)
| TyVrnSup of loc and ctyp (* [ > t ] *)
| TyVrnInf of loc and ctyp (* [ < t ] *)
| TyVrnInfSup of loc and ctyp and ctyp (* [ < t > t ] *)
| TyAmp of loc and ctyp and ctyp (* t & t *)
| TyOfAmp of loc and ctyp and ctyp (* t of & t *)
| TyPkg of loc and module_type (* (module S) *)
| TyAtt of loc and string and str_item and ctyp (* .. [@attr] *)
| TyAnt of loc and string (* $s$ *)
]
and patt =
[ PaNil of loc
| PaId of loc and ident (* i *)
| PaAli of loc and patt and patt (* p as p *) (* (Node x y as n) *)
| PaAnt of loc and string (* $s$ *)
| PaAny of loc (* _ *)
| PaApp of loc and patt and patt (* p p *) (* fun x y -> *)
| PaArr of loc and patt (* [| p |] *)
| PaCom of loc and patt and patt (* p, p *)
| PaSem of loc and patt and patt (* p; p *)
| PaChr of loc and string (* c *) (* 'x' *)
| PaInt of loc and string
| PaInt32 of loc and string
| PaInt64 of loc and string
| PaNativeInt of loc and string
| PaFlo of loc and string
| PaLab of loc and string and patt (* ~s or ~s:(p) *)
(* ?s or ?s:(p) *)
| PaOlb of loc and string and patt
(* ?s:(p = e) or ?(p = e) *)
| PaOlbi of loc and string and patt and expr
| PaOrp of loc and patt and patt (* p | p *)
| PaRng of loc and patt and patt (* p .. p *)
| PaRec of loc and patt (* { p } *)
| PaEq of loc and ident and patt (* i = p *)
| PaStr of loc and string (* s *)
| PaTup of loc and patt (* ( p ) *)
| PaTyc of loc and patt and ctyp (* (p : t) *)
| PaTyp of loc and ident (* #i *)
| PaVrn of loc and string (* `s *)
| PaLaz of loc and patt (* lazy p *)
| PaAtt of loc and string and str_item and patt (* .. [@attr] *)
| PaMod of loc and string (* (module M) *) ]
and expr =
[ ExNil of loc
| ExId of loc and ident (* i *)
| ExAcc of loc and expr and expr (* e.e *)
| ExAnt of loc and string (* $s$ *)
| ExApp of loc and expr and expr (* e e *)
| ExAre of loc and expr and expr (* e.(e) *)
| ExArr of loc and expr (* [| e |] *)
| ExSem of loc and expr and expr (* e; e *)
| ExAsf of loc (* assert False *)
| ExAsr of loc and expr (* assert e *)
| ExAss of loc and expr and expr (* e := e *)
| ExChr of loc and string (* 'c' *)
| ExCoe of loc and expr and ctyp and ctyp (* (e : t) or (e : t :> t) *)
| ExFlo of loc and string (* 3.14 *)
(* for s = e to/downto e do { e } *)
| ExFor of loc and string and expr and expr and direction_flag and expr
| ExFun of loc and match_case (* fun [ mc ] *)
| ExIfe of loc and expr and expr and expr (* if e then e else e *)
| ExInt of loc and string (* 42 *)
| ExInt32 of loc and string
| ExInt64 of loc and string
| ExNativeInt of loc and string
| ExLab of loc and string and expr (* ~s or ~s:e *)
| ExLaz of loc and expr (* lazy e *)
(* let b in e or let rec b in e *)
| ExLet of loc and rec_flag and binding and expr
(* let module s = me in e *)
| ExLmd of loc and string and module_expr and expr
(* match e with [ mc ] *)
| ExMat of loc and expr and match_case
(* new i *)
| ExNew of loc and ident
(* object ((p))? (cst)? end *)
| ExObj of loc and patt and class_str_item
(* ?s or ?s:e *)
| ExOlb of loc and string and expr
(* {< rb >} *)
| ExOvr of loc and rec_binding
(* { rb } or { (e) with rb } *)
| ExRec of loc and rec_binding and expr
(* do { e } *)
| ExSeq of loc and expr
(* e#s *)
| ExSnd of loc and expr and string
(* e.[e] *)
| ExSte of loc and expr and expr
(* s *) (* "foo" *)
| ExStr of loc and string
(* try e with [ mc ] *)
| ExTry of loc and expr and match_case
(* (e) *)
| ExTup of loc and expr
(* e, e *)
| ExCom of loc and expr and expr
(* (e : t) *)
| ExTyc of loc and expr and ctyp
(* `s *)
| ExVrn of loc and string
(* while e do { e } *)
| ExWhi of loc and expr and expr
(* let open i in e *)
| ExOpI of loc and ident and override_flag and expr
(* fun (type t) -> e *)
(* let f x (type t) y z = e *)
| ExFUN of loc and string and expr
(* (module ME : S) which is represented as (module (ME : S)) *)
| ExPkg of loc and module_expr
(* e [@attr] *)
| ExAtt of loc and string and str_item and expr
]
and module_type =
[ MtNil of loc
(* i *) (* A.B.C *)
| MtId of loc and ident
(* functor (s : mt) -> mt *)
| MtFun of loc and string and module_type and module_type
(* 's *)
| MtQuo of loc and string
(* sig sg end *)
| MtSig of loc and sig_item
(* mt with wc *)
| MtWit of loc and module_type and with_constr
(* module type of m *)
| MtOf of loc and module_expr
| MtAtt of loc and string and str_item and module_type (* .. [@attr] *)
| MtAnt of loc and string (* $s$ *) ]
and sig_item =
[ SgNil of loc
(* class cict *)
| SgCls of loc and class_type
(* class type cict *)
| SgClt of loc and class_type
(* sg ; sg *)
| SgSem of loc and sig_item and sig_item
(* # s or # s e *)
| SgDir of loc and string and expr
(* exception t *)
| SgExc of loc and ctyp
(* external s : t = s ... s *)
| SgExt of loc and string and ctyp and meta_list string
(* include mt *)
| SgInc of loc and module_type
(* module s : mt *)
| SgMod of loc and string and module_type
(* module rec mb *)
| SgRecMod of loc and module_binding
(* module type s = mt *)
| SgMty of loc and string and module_type
(* open i *)
| SgOpn of loc and ident
(* type t *)
| SgTyp of loc and ctyp
(* value s : t *)
| SgVal of loc and string and ctyp
| SgAnt of loc and string (* $s$ *) ]
and with_constr =
[ WcNil of loc
(* type t = t *)
| WcTyp of loc and ctyp and ctyp
(* module i = i *)
| WcMod of loc and ident and ident
(* type t := t *)
| WcTyS of loc and ctyp and ctyp
(* module i := i *)
| WcMoS of loc and ident and ident
(* wc and wc *)
| WcAnd of loc and with_constr and with_constr
| WcAnt of loc and string (* $s$ *) ]
and binding =
[ BiNil of loc
(* bi and bi *) (* let a = 42 and c = 43 *)
| BiAnd of loc and binding and binding
(* p = e *) (* let patt = expr *)
| BiEq of loc and patt and expr
| BiAnt of loc and string (* $s$ *) ]
and rec_binding =
[ RbNil of loc
(* rb ; rb *)
| RbSem of loc and rec_binding and rec_binding
(* i = e *)
| RbEq of loc and ident and expr
| RbAnt of loc and string (* $s$ *) ]
and module_binding =
[ MbNil of loc
(* mb and mb *) (* module rec (s : mt) = me and (s : mt) = me *)
| MbAnd of loc and module_binding and module_binding
(* s : mt = me *)
| MbColEq of loc and string and module_type and module_expr
(* s : mt *)
| MbCol of loc and string and module_type
| MbAnt of loc and string (* $s$ *) ]
and match_case =
[ McNil of loc
(* a | a *)
| McOr of loc and match_case and match_case
(* p (when e)? -> e *)
| McArr of loc and patt and expr and expr
| McAnt of loc and string (* $s$ *) ]
and module_expr =
[ MeNil of loc
(* i *)
| MeId of loc and ident
(* me me *)
| MeApp of loc and module_expr and module_expr
(* functor (s : mt) -> me *)
| MeFun of loc and string and module_type and module_expr
(* struct st end *)
| MeStr of loc and str_item
(* (me : mt) *)
| MeTyc of loc and module_expr and module_type
(* (value e) *)
(* (value e : S) which is represented as (value (e : S)) *)
| MePkg of loc and expr
| MeAtt of loc and string and str_item and module_expr (* .. [@attr] *)
| MeAnt of loc and string (* $s$ *) ]
and str_item =
[ StNil of loc
(* class cice *)
| StCls of loc and class_expr
(* class type cict *)
| StClt of loc and class_type
(* st ; st *)
| StSem of loc and str_item and str_item
(* # s or # s e *)
| StDir of loc and string and expr
(* exception t or exception t = i *)
| StExc of loc and ctyp and meta_option(*FIXME*) ident
(* e *)
| StExp of loc and expr
(* external s : t = s ... s *)
| StExt of loc and string and ctyp and meta_list string
(* include me *)
| StInc of loc and module_expr
(* module s = me *)
| StMod of loc and string and module_expr
(* module rec mb *)
| StRecMod of loc and module_binding
(* module type s = mt *)
| StMty of loc and string and module_type
(* open i *)
| StOpn of loc and override_flag and ident
(* type t *)
| StTyp of loc and ctyp
(* value (rec)? bi *)
| StVal of loc and rec_flag and binding
| StAnt of loc and string (* $s$ *) ]
and class_type =
[ CtNil of loc
(* (virtual)? i ([ t ])? *)
| CtCon of loc and virtual_flag and ident and ctyp
(* [t] -> ct *)
| CtFun of loc and ctyp and class_type
(* object ((t))? (csg)? end *)
| CtSig of loc and ctyp and class_sig_item
(* ct and ct *)
| CtAnd of loc and class_type and class_type
(* ct : ct *)
| CtCol of loc and class_type and class_type
(* ct = ct *)
| CtEq of loc and class_type and class_type
(* $s$ *)
| CtAtt of loc and string and str_item and class_type (* .. [@attr] *)
| CtAnt of loc and string ]
and class_sig_item =
[ CgNil of loc
(* type t = t *)
| CgCtr of loc and ctyp and ctyp
(* csg ; csg *)
| CgSem of loc and class_sig_item and class_sig_item
(* inherit ct *)
| CgInh of loc and class_type
(* method s : t or method private s : t *)
| CgMth of loc and string and private_flag and ctyp
(* value (virtual)? (mutable)? s : t *)
| CgVal of loc and string and mutable_flag and virtual_flag and ctyp
(* method virtual (private)? s : t *)
| CgVir of loc and string and private_flag and ctyp
| CgAnt of loc and string (* $s$ *) ]
and class_expr =
[ CeNil of loc
(* ce e *)
| CeApp of loc and class_expr and expr
(* (virtual)? i ([ t ])? *)
| CeCon of loc and virtual_flag and ident and ctyp
(* fun p -> ce *)
| CeFun of loc and patt and class_expr
(* let (rec)? bi in ce *)
| CeLet of loc and rec_flag and binding and class_expr
(* object ((p))? (cst)? end *)
| CeStr of loc and patt and class_str_item
(* ce : ct *)
| CeTyc of loc and class_expr and class_type
(* ce and ce *)
| CeAnd of loc and class_expr and class_expr
(* ce = ce *)
| CeEq of loc and class_expr and class_expr
(* $s$ *)
| CeAtt of loc and string and str_item and class_expr (* .. [@attr] *)
| CeAnt of loc and string ]
and class_str_item =
[ CrNil of loc
(* cst ; cst *)
| CrSem of loc and class_str_item and class_str_item
(* type t = t *)
| CrCtr of loc and ctyp and ctyp
(* inherit(!)? ce (as s)? *)
| CrInh of loc and override_flag and class_expr and string
(* initializer e *)
| CrIni of loc and expr
(* method(!)? (private)? s : t = e or method(!)? (private)? s = e *)
| CrMth of loc and string and override_flag and private_flag and expr and ctyp
(* value(!)? (mutable)? s = e *)
| CrVal of loc and string and override_flag and mutable_flag and expr
(* method virtual (private)? s : t *)
| CrVir of loc and string and private_flag and ctyp
(* value virtual (mutable)? s : t *)
| CrVvr of loc and string and mutable_flag and ctyp
| CrAnt of loc and string (* $s$ *) ];

64
camlp4/Camlp4/Debug.ml
View File

@ -1,64 +0,0 @@
(****************************************************************************)
(* *)
(* OCaml *)
(* *)
(* INRIA Rocquencourt *)
(* *)
(* Copyright 2006 Institut National de Recherche en Informatique et *)
(* en Automatique. All rights reserved. This file is distributed under *)
(* the terms of the GNU Library General Public License, with the special *)
(* exception on linking described in LICENSE at the top of the OCaml *)
(* source tree. *)
(* *)
(****************************************************************************)
(* Authors:
* - Daniel de Rauglaudre: initial version
* - Nicolas Pouillard: refactoring
*)
(* camlp4r *)
open Format;
module Debug = struct value mode _ = False; end;
type section = string;
value out_channel =
try
let f = Sys.getenv "CAMLP4_DEBUG_FILE" in
open_out_gen [Open_wronly; Open_creat; Open_append; Open_text]
0o666 f
with
[ Not_found -> Pervasives.stderr ];
module StringSet = Set.Make String;
value mode =
try
let str = Sys.getenv "CAMLP4_DEBUG" in
let rec loop acc i =
try
let pos = String.index_from str i ':' in
loop (StringSet.add (String.sub str i (pos - i)) acc) (pos + 1)
with
[ Not_found ->
StringSet.add (String.sub str i (String.length str - i)) acc ] in
let sections = loop StringSet.empty 0 in
if StringSet.mem "*" sections then fun _ -> True
else fun x -> StringSet.mem x sections
with [ Not_found -> fun _ -> False ];
value formatter =
let header = "camlp4-debug: " in
let at_bol = ref True in
(make_formatter
(fun buf pos len ->
for i = pos to pos + len - 1 do
if at_bol.val then output_string out_channel header else ();
let ch = buf.[i];
output_char out_channel ch;
at_bol.val := ch = '\n';
done)
(fun () -> flush out_channel));
value printf section fmt = fprintf formatter ("%s: " ^^ fmt) section;

22
camlp4/Camlp4/Debug.mli
View File

@ -1,22 +0,0 @@
(****************************************************************************)
(* *)
(* OCaml *)
(* *)
(* INRIA Rocquencourt *)
(* *)
(* Copyright 2006 Institut National de Recherche en Informatique et *)
(* en Automatique. All rights reserved. This file is distributed under *)
(* the terms of the GNU Library General Public License, with the special *)
(* exception on linking described in LICENSE at the top of the OCaml *)
(* source tree. *)
(* *)
(****************************************************************************)
(* Authors:
* - Daniel de Rauglaudre: initial version
* - Nicolas Pouillard: refactoring
*)
(* camlp4r *)
type section = string;
value mode : section -> bool;
value printf : section -> format 'a Format.formatter unit -> 'a;

171
camlp4/Camlp4/ErrorHandler.ml
View File

@ -1,171 +0,0 @@
(****************************************************************************)
(* *)
(* OCaml *)
(* *)
(* INRIA Rocquencourt *)
(* *)
(* Copyright 2006 Institut National de Recherche en Informatique et *)
(* en Automatique. All rights reserved. This file is distributed under *)
(* the terms of the GNU Library General Public License, with the special *)
(* exception on linking described in LICENSE at the top of the OCaml *)
(* source tree. *)
(* *)
(****************************************************************************)
(* Authors:
* - Daniel de Rauglaudre: initial version
* - Nicolas Pouillard: refactoring
*)
(* camlp4r *)
open Format;
module ObjTools = struct
value desc obj =
if Obj.is_block obj then
"tag = " ^ string_of_int (Obj.tag obj)
else "int_val = " ^ string_of_int (Obj.obj obj);
(*Imported from the extlib*)
value rec to_string r =
if Obj.is_int r then
let i = (Obj.magic r : int)
in string_of_int i ^ " | CstTag" ^ string_of_int (i + 1)
else (* Block. *)
let rec get_fields acc =
fun
[ 0 -> acc
| n -> let n = n-1 in get_fields [Obj.field r n :: acc] n ]
in
let rec is_list r =
if Obj.is_int r then
r = Obj.repr 0 (* [] *)
else
let s = Obj.size r and t = Obj.tag r in
t = 0 && s = 2 && is_list (Obj.field r 1) (* h :: t *)
in
let rec get_list r =
if Obj.is_int r then []
else let h = Obj.field r 0 and t = get_list (Obj.field r 1) in [h :: t]
in
let opaque name =
(* XXX In future, print the address of value 'r'. Not possible in
* pure OCaml at the moment.
*)
"<" ^ name ^ ">"
in
let s = Obj.size r and t = Obj.tag r in
(* From the tag, determine the type of block. *)
match t with
[ _ when is_list r ->
let fields = get_list r in
"[" ^ String.concat "; " (List.map to_string fields) ^ "]"
| 0 ->
let fields = get_fields [] s in
"(" ^ String.concat ", " (List.map to_string fields) ^ ")"
| x when x = Obj.lazy_tag ->
(* Note that [lazy_tag .. forward_tag] are < no_scan_tag. Not
* clear if very large constructed values could have the same
* tag. XXX *)
opaque "lazy"
| x when x = Obj.closure_tag ->
opaque "closure"
| x when x = Obj.object_tag ->
let fields = get_fields [] s in
let (_class, id, slots) =
match fields with
[ [h; h'::t] -> (h, h', t)
| _ -> assert False ]
in
(* No information on decoding the class (first field). So just print
* out the ID and the slots. *)
"Object #" ^ to_string id ^ " (" ^ String.concat ", " (List.map to_string slots) ^ ")"
| x when x = Obj.infix_tag ->
opaque "infix"
| x when x = Obj.forward_tag ->
opaque "forward"
| x when x < Obj.no_scan_tag ->
let fields = get_fields [] s in
"Tag" ^ string_of_int t ^
" (" ^ String.concat ", " (List.map to_string fields) ^ ")"
| x when x = Obj.string_tag ->
"\"" ^ String.escaped (Obj.magic r : string) ^ "\""
| x when x = Obj.double_tag ->
Camlp4_import.Oprint.float_repres (Obj.magic r : float)
| x when x = Obj.abstract_tag ->
opaque "abstract"
| x when x = Obj.custom_tag ->
opaque "custom"
| x when x = Obj.final_tag ->
opaque "final"
| _ ->
failwith ("ObjTools.to_string: unknown tag (" ^ string_of_int t ^ ")") ];
value print ppf x = fprintf ppf "%s" (to_string x);
value print_desc ppf x = fprintf ppf "%s" (desc x);
end;
value default_handler ppf x = do {
let x = Obj.repr x;
fprintf ppf "Camlp4: Uncaught exception: %s"
(Obj.obj (Obj.field (Obj.field x 0) 0) : string);
if Obj.size x > 1 then do {
pp_print_string ppf " (";
for i = 1 to Obj.size x - 1 do
if i > 1 then pp_print_string ppf ", " else ();
ObjTools.print ppf (Obj.field x i);
done;
pp_print_char ppf ')'
}
else ();
fprintf ppf "@."
};
value handler = ref (fun ppf default_handler exn -> default_handler ppf exn);
value register f =
let current_handler = handler.val in
handler.val :=
fun ppf default_handler exn ->
try f ppf exn with exn -> current_handler ppf default_handler exn;
module Register (Error : Sig.Error) = struct
let current_handler = handler.val in
handler.val :=
fun ppf default_handler ->
fun [ Error.E x -> Error.print ppf x
| x -> current_handler ppf default_handler x ];
end;
value gen_print ppf default_handler =
fun
[ Out_of_memory -> fprintf ppf "Out of memory"
| Assert_failure (file, line, char) ->
fprintf ppf "Assertion failed, file %S, line %d, char %d"
file line char
| Match_failure (file, line, char) ->
fprintf ppf "Pattern matching failed, file %S, line %d, char %d"
file line char
| Failure str -> fprintf ppf "Failure: %S" str
| Invalid_argument str -> fprintf ppf "Invalid argument: %S" str
| Sys_error str -> fprintf ppf "I/O error: %S" str
| Stream.Failure -> fprintf ppf "Parse failure"
| Stream.Error str -> fprintf ppf "Parse error: %s" str
| x -> handler.val ppf default_handler x ];
value print ppf = gen_print ppf default_handler;
value try_print ppf = gen_print ppf (fun _ -> raise);
value to_string exn =
let buf = Buffer.create 128 in
let () = bprintf buf "%a" print exn in
Buffer.contents buf;
value try_to_string exn =
let buf = Buffer.create 128 in
let () = bprintf buf "%a" try_print exn in
Buffer.contents buf;

36
camlp4/Camlp4/ErrorHandler.mli
View File

@ -1,36 +0,0 @@
(****************************************************************************)
(* *)
(* OCaml *)
(* *)
(* INRIA Rocquencourt *)
(* *)
(* Copyright 2006 Institut National de Recherche en Informatique et *)
(* en Automatique. All rights reserved. This file is distributed under *)
(* the terms of the GNU Library General Public License, with the special *)
(* exception on linking described in LICENSE at the top of the OCaml *)
(* source tree. *)
(* *)
(****************************************************************************)
(* Authors:
* - Nicolas Pouillard: initial version
*)
value print : Format.formatter -> exn -> unit;
value try_print : Format.formatter -> exn -> unit;
value to_string : exn -> string;
value try_to_string : exn -> string;
value register : (Format.formatter -> exn -> unit) -> unit;
module Register (Error : Sig.Error) : sig end;
module ObjTools : sig
value print : Format.formatter -> Obj.t -> unit;
value print_desc : Format.formatter -> Obj.t -> unit;
(*Imported from the extlib*)
value to_string : Obj.t -> string;
value desc : Obj.t -> string;
end;

265
camlp4/Camlp4/OCamlInitSyntax.ml
View File

@ -1,265 +0,0 @@
(****************************************************************************)
(* *)
(* OCaml *)
(* *)
(* INRIA Rocquencourt *)
(* *)
(* Copyright 2006 Institut National de Recherche en Informatique et *)
(* en Automatique. All rights reserved. This file is distributed under *)
(* the terms of the GNU Library General Public License, with the special *)
(* exception on linking described in LICENSE at the top of the OCaml *)
(* source tree. *)
(* *)
(****************************************************************************)
(* Authors:
* - Nicolas Pouillard: initial version
*)
module Make (Ast : Sig.Camlp4Ast)
(Gram : Sig.Grammar.Static with module Loc = Ast.Loc
with type Token.t = Sig.camlp4_token)
(Quotation : Sig.Quotation with module Ast = Sig.Camlp4AstToAst Ast)
: Sig.Camlp4Syntax with module Loc = Ast.Loc
and module Ast = Ast
and module Token = Gram.Token
and module Gram = Gram
and module Quotation = Quotation
= struct
module Loc = Ast.Loc;
module Ast = Ast;
module Gram = Gram;
module Token = Gram.Token;
open Sig;
(* Warnings *)
type warning = Loc.t -> string -> unit;
value default_warning loc txt = Format.eprintf "<W> %a: %s@." Loc.print loc txt;
value current_warning = ref default_warning;
value print_warning loc txt = current_warning.val loc txt;
value a_CHAR = Gram.Entry.mk "a_CHAR";
value a_FLOAT = Gram.Entry.mk "a_FLOAT";
value a_INT = Gram.Entry.mk "a_INT";
value a_INT32 = Gram.Entry.mk "a_INT32";
value a_INT64 = Gram.Entry.mk "a_INT64";
value a_LABEL = Gram.Entry.mk "a_LABEL";
value a_LIDENT = Gram.Entry.mk "a_LIDENT";
value a_NATIVEINT = Gram.Entry.mk "a_NATIVEINT";
value a_OPTLABEL = Gram.Entry.mk "a_OPTLABEL";
value a_STRING = Gram.Entry.mk "a_STRING";
value a_UIDENT = Gram.Entry.mk "a_UIDENT";
value a_ident = Gram.Entry.mk "a_ident";
value amp_ctyp = Gram.Entry.mk "amp_ctyp";
value and_ctyp = Gram.Entry.mk "and_ctyp";
value match_case = Gram.Entry.mk "match_case";
value match_case0 = Gram.Entry.mk "match_case0";
value binding = Gram.Entry.mk "binding";
value class_declaration = Gram.Entry.mk "class_declaration";
value class_description = Gram.Entry.mk "class_description";
value class_expr = Gram.Entry.mk "class_expr";
value class_fun_binding = Gram.Entry.mk "class_fun_binding";
value class_fun_def = Gram.Entry.mk "class_fun_def";
value class_info_for_class_expr = Gram.Entry.mk "class_info_for_class_expr";
value class_info_for_class_type = Gram.Entry.mk "class_info_for_class_type";
value class_longident = Gram.Entry.mk "class_longident";
value class_longident_and_param = Gram.Entry.mk "class_longident_and_param";
value class_name_and_param = Gram.Entry.mk "class_name_and_param";
value class_sig_item = Gram.Entry.mk "class_sig_item";
value class_signature = Gram.Entry.mk "class_signature";
value class_str_item = Gram.Entry.mk "class_str_item";
value class_structure = Gram.Entry.mk "class_structure";
value class_type = Gram.Entry.mk "class_type";
value class_type_declaration = Gram.Entry.mk "class_type_declaration";
value class_type_longident = Gram.Entry.mk "class_type_longident";
value class_type_longident_and_param = Gram.Entry.mk "class_type_longident_and_param";
value class_type_plus = Gram.Entry.mk "class_type_plus";
value comma_ctyp = Gram.Entry.mk "comma_ctyp";
value comma_expr = Gram.Entry.mk "comma_expr";
value comma_ipatt = Gram.Entry.mk "comma_ipatt";
value comma_patt = Gram.Entry.mk "comma_patt";
value comma_type_parameter = Gram.Entry.mk "comma_type_parameter";
value constrain = Gram.Entry.mk "constrain";
value constructor_arg_list = Gram.Entry.mk "constructor_arg_list";
value constructor_declaration = Gram.Entry.mk "constructor_declaration";
value constructor_declarations = Gram.Entry.mk "constructor_declarations";
value ctyp = Gram.Entry.mk "ctyp";
value cvalue_binding = Gram.Entry.mk "cvalue_binding";
value direction_flag = Gram.Entry.mk "direction_flag";
value direction_flag_quot = Gram.Entry.mk "direction_flag_quot";
value dummy = Gram.Entry.mk "dummy";
value entry_eoi = Gram.Entry.mk "entry_eoi";
value eq_expr = Gram.Entry.mk "eq_expr";
value expr = Gram.Entry.mk "expr";
value expr_eoi = Gram.Entry.mk "expr_eoi";
value field_expr = Gram.Entry.mk "field_expr";
value field_expr_list = Gram.Entry.mk "field_expr_list";
value fun_binding = Gram.Entry.mk "fun_binding";
value fun_def = Gram.Entry.mk "fun_def";
value ident = Gram.Entry.mk "ident";
value implem = Gram.Entry.mk "implem";
value interf = Gram.Entry.mk "interf";
value ipatt = Gram.Entry.mk "ipatt";
value ipatt_tcon = Gram.Entry.mk "ipatt_tcon";
value label = Gram.Entry.mk "label";
value label_declaration = Gram.Entry.mk "label_declaration";
value label_declaration_list = Gram.Entry.mk "label_declaration_list";
value label_expr = Gram.Entry.mk "label_expr";
value label_expr_list = Gram.Entry.mk "label_expr_list";
value label_ipatt = Gram.Entry.mk "label_ipatt";
value label_ipatt_list = Gram.Entry.mk "label_ipatt_list";
value label_longident = Gram.Entry.mk "label_longident";
value label_patt = Gram.Entry.mk "label_patt";
value label_patt_list = Gram.Entry.mk "label_patt_list";
value labeled_ipatt = Gram.Entry.mk "labeled_ipatt";
value let_binding = Gram.Entry.mk "let_binding";
value meth_list = Gram.Entry.mk "meth_list";
value meth_decl = Gram.Entry.mk "meth_decl";
value module_binding = Gram.Entry.mk "module_binding";
value module_binding0 = Gram.Entry.mk "module_binding0";
value module_declaration = Gram.Entry.mk "module_declaration";
value module_expr = Gram.Entry.mk "module_expr";
value module_longident = Gram.Entry.mk "module_longident";
value module_longident_with_app = Gram.Entry.mk "module_longident_with_app";
value module_rec_declaration = Gram.Entry.mk "module_rec_declaration";
value module_type = Gram.Entry.mk "module_type";
value package_type = Gram.Entry.mk "package_type";
value more_ctyp = Gram.Entry.mk "more_ctyp";
value name_tags = Gram.Entry.mk "name_tags";
value opt_as_lident = Gram.Entry.mk "opt_as_lident";
value opt_class_self_patt = Gram.Entry.mk "opt_class_self_patt";
value opt_class_self_type = Gram.Entry.mk "opt_class_self_type";
value opt_class_signature = Gram.Entry.mk "opt_class_signature";
value opt_class_structure = Gram.Entry.mk "opt_class_structure";
value opt_comma_ctyp = Gram.Entry.mk "opt_comma_ctyp";
value opt_dot_dot = Gram.Entry.mk "opt_dot_dot";
value row_var_flag_quot = Gram.Entry.mk "row_var_flag_quot";
value opt_eq_ctyp = Gram.Entry.mk "opt_eq_ctyp";
value opt_expr = Gram.Entry.mk "opt_expr";
value opt_meth_list = Gram.Entry.mk "opt_meth_list";
value opt_mutable = Gram.Entry.mk "opt_mutable";
value mutable_flag_quot = Gram.Entry.mk "mutable_flag_quot";
value opt_polyt = Gram.Entry.mk "opt_polyt";
value opt_private = Gram.Entry.mk "opt_private";
value private_flag_quot = Gram.Entry.mk "private_flag_quot";
value opt_rec = Gram.Entry.mk "opt_rec";
value rec_flag_quot = Gram.Entry.mk "rec_flag_quot";
value opt_sig_items = Gram.Entry.mk "opt_sig_items";
value opt_str_items = Gram.Entry.mk "opt_str_items";
value opt_virtual = Gram.Entry.mk "opt_virtual";
value virtual_flag_quot = Gram.Entry.mk "virtual_flag_quot";
value opt_override = Gram.Entry.mk "opt_override";
value override_flag_quot = Gram.Entry.mk "override_flag_quot";
value opt_when_expr = Gram.Entry.mk "opt_when_expr";
value patt = Gram.Entry.mk "patt";
value patt_as_patt_opt = Gram.Entry.mk "patt_as_patt_opt";
value patt_eoi = Gram.Entry.mk "patt_eoi";
value patt_tcon = Gram.Entry.mk "patt_tcon";
value phrase = Gram.Entry.mk "phrase";
value poly_type = Gram.Entry.mk "poly_type";
value row_field = Gram.Entry.mk "row_field";
value sem_expr = Gram.Entry.mk "sem_expr";
value sem_expr_for_list = Gram.Entry.mk "sem_expr_for_list";
value sem_patt = Gram.Entry.mk "sem_patt";
value sem_patt_for_list = Gram.Entry.mk "sem_patt_for_list";
value semi = Gram.Entry.mk "semi";
value sequence = Gram.Entry.mk "sequence";
value do_sequence = Gram.Entry.mk "do_sequence";
value sig_item = Gram.Entry.mk "sig_item";
value sig_items = Gram.Entry.mk "sig_items";
value star_ctyp = Gram.Entry.mk "star_ctyp";
value str_item = Gram.Entry.mk "str_item";
value str_items = Gram.Entry.mk "str_items";
value top_phrase = Gram.Entry.mk "top_phrase";
value type_constraint = Gram.Entry.mk "type_constraint";
value type_declaration = Gram.Entry.mk "type_declaration";
value type_ident_and_parameters = Gram.Entry.mk "type_ident_and_parameters";
value type_kind = Gram.Entry.mk "type_kind";
value type_longident = Gram.Entry.mk "type_longident";
value type_longident_and_parameters = Gram.Entry.mk "type_longident_and_parameters";
value type_parameter = Gram.Entry.mk "type_parameter";
value type_parameters = Gram.Entry.mk "type_parameters";
value typevars = Gram.Entry.mk "typevars";
value use_file = Gram.Entry.mk "use_file";
value val_longident = Gram.Entry.mk "val_longident";
value value_let = Gram.Entry.mk "value_let";
value value_val = Gram.Entry.mk "value_val";
value with_constr = Gram.Entry.mk "with_constr";
value expr_quot = Gram.Entry.mk "quotation of expression";
value patt_quot = Gram.Entry.mk "quotation of pattern";
value ctyp_quot = Gram.Entry.mk "quotation of type";
value str_item_quot = Gram.Entry.mk "quotation of structure item";
value sig_item_quot = Gram.Entry.mk "quotation of signature item";
value class_str_item_quot = Gram.Entry.mk "quotation of class structure item";
value class_sig_item_quot = Gram.Entry.mk "quotation of class signature item";
value module_expr_quot = Gram.Entry.mk "quotation of module expression";
value module_type_quot = Gram.Entry.mk "quotation of module type";
value class_type_quot = Gram.Entry.mk "quotation of class type";
value class_expr_quot = Gram.Entry.mk "quotation of class expression";
value with_constr_quot = Gram.Entry.mk "quotation of with constraint";
value binding_quot = Gram.Entry.mk "quotation of binding";
value rec_binding_quot = Gram.Entry.mk "quotation of record binding";
value match_case_quot = Gram.Entry.mk "quotation of match_case (try/match/function case)";
value module_binding_quot = Gram.Entry.mk "quotation of module rec binding";
value ident_quot = Gram.Entry.mk "quotation of identifier";
value prefixop = Gram.Entry.mk "prefix operator (start with '!', '?', '~')";
value infixop0 = Gram.Entry.mk "infix operator (level 0) (comparison operators, and some others)";
value infixop1 = Gram.Entry.mk "infix operator (level 1) (start with '^', '@')";
value infixop2 = Gram.Entry.mk "infix operator (level 2) (start with '+', '-')";
value infixop3 = Gram.Entry.mk "infix operator (level 3) (start with '*', '/', '%')";
value infixop4 = Gram.Entry.mk "infix operator (level 4) (start with \"**\") (right assoc)";
EXTEND Gram
top_phrase:
[ [ `EOI -> None ] ]
;
END;
module AntiquotSyntax = struct
module Loc = Ast.Loc;
module Ast = Sig.Camlp4AstToAst Ast;
module Gram = Gram;
value antiquot_expr = Gram.Entry.mk "antiquot_expr";
value antiquot_patt = Gram.Entry.mk "antiquot_patt";
EXTEND Gram
antiquot_expr:
[ [ x = expr; `EOI -> x ] ]
;
antiquot_patt:
[ [ x = patt; `EOI -> x ] ]
;
END;
value parse_expr loc str = Gram.parse_string antiquot_expr loc str;
value parse_patt loc str = Gram.parse_string antiquot_patt loc str;
end;
module Quotation = Quotation;
value wrap directive_handler pa init_loc cs =
let rec loop loc =
let (pl, stopped_at_directive) = pa loc cs in
match stopped_at_directive with
[ Some new_loc ->
let pl =
match List.rev pl with
[ [] -> assert False
| [x :: xs] ->
match directive_handler x with
[ None -> xs
| Some x -> [x :: xs] ] ]
in (List.rev pl) @ (loop new_loc)
| None -> pl ]
in loop init_loc;
value parse_implem ?(directive_handler = fun _ -> None) _loc cs =
let l = wrap directive_handler (Gram.parse implem) _loc cs in
<:str_item< $list:l$ >>;
value parse_interf ?(directive_handler = fun _ -> None) _loc cs =
let l = wrap directive_handler (Gram.parse interf) _loc cs in
<:sig_item< $list:l$ >>;
value print_interf ?input_file:(_) ?output_file:(_) _ = failwith "No interface printer";
value print_implem ?input_file:(_) ?output_file:(_) _ = failwith "No implementation printer";
end;

191
camlp4/Camlp4/Options.ml
View File

@ -1,191 +0,0 @@
(****************************************************************************)
(* *)
(* OCaml *)
(* *)
(* INRIA Rocquencourt *)
(* *)
(* Copyright 2006 Institut National de Recherche en Informatique et *)
(* en Automatique. All rights reserved. This file is distributed under *)
(* the terms of the GNU Library General Public License, with the special *)
(* exception on linking described in LICENSE at the top of the OCaml *)
(* source tree. *)
(* *)
(****************************************************************************)
(* Authors:
* - Daniel de Rauglaudre: initial version
* - Nicolas Pouillard: refactoring
*)
type spec_list = list (string * Arg.spec * string);
open Format;
value rec action_arg s sl =
fun
[ Arg.Unit f -> if s = "" then do { f (); Some sl } else None
| Arg.Bool f ->
if s = "" then
match sl with
[ [s :: sl] ->
try do { f (bool_of_string s); Some sl } with
[ Invalid_argument "bool_of_string" -> None ]
| [] -> None ]
else
try do { f (bool_of_string s); Some sl } with
[ Invalid_argument "bool_of_string" -> None ]
| Arg.Set r -> if s = "" then do { r.val := True; Some sl } else None
| Arg.Clear r -> if s = "" then do { r.val := False; Some sl } else None
| Arg.Rest f -> do { List.iter f [s :: sl]; Some [] }
| Arg.String f ->
if s = "" then
match sl with
[ [s :: sl] -> do { f s; Some sl }
| [] -> None ]
else do { f s; Some sl }
| Arg.Set_string r ->
if s = "" then
match sl with
[ [s :: sl] -> do { r.val := s; Some sl }
| [] -> None ]
else do { r.val := s; Some sl }
| Arg.Int f ->
if s = "" then
match sl with
[ [s :: sl] ->
try do { f (int_of_string s); Some sl } with
[ Failure "int_of_string" -> None ]
| [] -> None ]
else
try do { f (int_of_string s); Some sl } with
[ Failure "int_of_string" -> None ]
| Arg.Set_int r ->
if s = "" then
match sl with
[ [s :: sl] ->
try do { r.val := (int_of_string s); Some sl } with
[ Failure "int_of_string" -> None ]
| [] -> None ]
else
try do { r.val := (int_of_string s); Some sl } with
[ Failure "int_of_string" -> None ]
| Arg.Float f ->
if s = "" then
match sl with
[ [s :: sl] -> do { f (float_of_string s); Some sl }
| [] -> None ]
else do { f (float_of_string s); Some sl }
| Arg.Set_float r ->
if s = "" then
match sl with
[ [s :: sl] -> do { r.val := (float_of_string s); Some sl }
| [] -> None ]
else do { r.val := (float_of_string s); Some sl }
| Arg.Tuple specs ->
let rec action_args s sl =
fun
[ [] -> Some sl
| [spec :: spec_list] ->
match action_arg s sl spec with
[ None -> action_args "" [] spec_list
| Some [s :: sl] -> action_args s sl spec_list
| Some sl -> action_args "" sl spec_list
]
] in
action_args s sl specs
| Arg.Symbol syms f ->
match (if s = "" then sl else [s :: sl]) with
[ [s :: sl] when List.mem s syms -> do { f s; Some sl }
| _ -> None ]
];
value common_start s1 s2 =
loop 0 where rec loop i =
if i == String.length s1 || i == String.length s2 then i
else if s1.[i] == s2.[i] then loop (i + 1)
else i;
value parse_arg fold s sl =
fold
(fun (name, action, _) acu ->
let i = common_start s name in
if i == String.length name then
try action_arg (String.sub s i (String.length s - i)) sl action with
[ Arg.Bad _ -> acu ]
else acu) None;
value rec parse_aux fold anon_fun =
fun
[ [] -> []
| [s :: sl] ->
if String.length s > 1 && s.[0] = '-' then
match parse_arg fold s sl with
[ Some sl -> parse_aux fold anon_fun sl
| None -> [s :: parse_aux fold anon_fun sl] ]
else do { (anon_fun s : unit); parse_aux fold anon_fun sl } ];
value align_doc key s =
let s =
loop 0 where rec loop i =
if i = String.length s then ""
else if s.[i] = ' ' then loop (i + 1)
else String.sub s i (String.length s - i)
in
let (p, s) =
if String.length s > 0 then
if s.[0] = '<' then
loop 0 where rec loop i =
if i = String.length s then ("", s)
else if s.[i] <> '>' then loop (i + 1)
else
let p = String.sub s 0 (i + 1) in
loop (i + 1) where rec loop i =
if i >= String.length s then (p, "")
else if s.[i] = ' ' then loop (i + 1)
else (p, String.sub s i (String.length s - i))
else ("", s)
else ("", "")
in
let tab =
String.make (max 1 (16 - String.length key - String.length p)) ' '
in
p ^ tab ^ s;
value make_symlist l =
match l with
[ [] -> "<none>"
| [h::t] -> (List.fold_left (fun x y -> x ^ "|" ^ y) ("{" ^ h) t) ^ "}" ];
value print_usage_list l =
List.iter
(fun (key, spec, doc) ->
match spec with
[ Arg.Symbol symbs _ ->
let s = make_symlist symbs in
let synt = key ^ " " ^ s in
eprintf " %s %s\n" synt (align_doc synt doc)
| _ -> eprintf " %s %s\n" key (align_doc key doc) ] )
l;
value remaining_args argv =
let rec loop l i =
if i == Array.length argv then l else loop [argv.(i) :: l] (i + 1)
in
List.rev (loop [] (Arg.current.val + 1));
value init_spec_list = ref [];
value ext_spec_list = ref [];
value init spec_list = init_spec_list.val := spec_list;
value add name spec descr =
ext_spec_list.val := [(name, spec, descr) :: ext_spec_list.val];
value fold f init =
let spec_list = init_spec_list.val @ ext_spec_list.val in
let specs = Sort.list (fun (k1, _, _) (k2, _, _) -> k1 >= k2) spec_list in
List.fold_right f specs init;
value parse anon_fun argv =
let remaining_args = remaining_args argv in
parse_aux fold anon_fun remaining_args;
value ext_spec_list () = ext_spec_list.val;

26
camlp4/Camlp4/Options.mli
View File

@ -1,26 +0,0 @@
(****************************************************************************)
(* *)
(* OCaml *)
(* *)
(* INRIA Rocquencourt *)
(* *)
(* Copyright 2006 Institut National de Recherche en Informatique et *)
(* en Automatique. All rights reserved. This file is distributed under *)
(* the terms of the GNU Library General Public License, with the special *)
(* exception on linking described in LICENSE at the top of the OCaml *)
(* source tree. *)
(* *)
(****************************************************************************)
(* Authors:
* - Daniel de Rauglaudre: initial version
* - Nicolas Pouillard: refactoring
*)
type spec_list = list (string * Arg.spec * string);
value init : spec_list -> unit;
value add : string -> Arg.spec -> string -> unit;
(** Add an option to the command line options. *)
value print_usage_list : spec_list -> unit;
value ext_spec_list : unit -> spec_list;
value parse : (string -> unit) -> array string -> list string;

67
camlp4/Camlp4/PreCast.ml
View File

@ -1,67 +0,0 @@
(****************************************************************************)
(* *)
(* OCaml *)
(* *)
(* INRIA Rocquencourt *)
(* *)
(* Copyright 2006 Institut National de Recherche en Informatique et *)
(* en Automatique. All rights reserved. This file is distributed under *)
(* the terms of the GNU Library General Public License, with the special *)
(* exception on linking described in LICENSE at the top of the OCaml *)
(* source tree. *)
(* *)
(****************************************************************************)
(* Authors:
* - Daniel de Rauglaudre: initial version
* - Nicolas Pouillard: refactoring
*)
module Id = struct
value name = "Camlp4.PreCast";
value version = Sys.ocaml_version;
end;
type camlp4_token = Sig.camlp4_token ==
[ KEYWORD of string
| SYMBOL of string
| LIDENT of string
| UIDENT of string
| ESCAPED_IDENT of string
| INT of int and string
| INT32 of int32 and string
| INT64 of int64 and string
| NATIVEINT of nativeint and string
| FLOAT of float and string
| CHAR of char and string
| STRING of string and string
| LABEL of string
| OPTLABEL of string
| QUOTATION of Sig.quotation
| ANTIQUOT of string and string
| COMMENT of string
| BLANKS of string
| NEWLINE
| LINE_DIRECTIVE of int and option string
| EOI ];
module Loc = Struct.Loc;
module Ast = Struct.Camlp4Ast.Make Loc;
module Token = Struct.Token.Make Loc;
module Lexer = Struct.Lexer.Make Token;
module Gram = Struct.Grammar.Static.Make Lexer;
module DynLoader = Struct.DynLoader;
module Quotation = Struct.Quotation.Make Ast;
module MakeSyntax (U : sig end) = OCamlInitSyntax.Make Ast Gram Quotation;
module Syntax = MakeSyntax (struct end);
module AstFilters = Struct.AstFilters.Make Ast;
module MakeGram = Struct.Grammar.Static.Make;
module Printers = struct
module OCaml = Printers.OCaml.Make Syntax;
module OCamlr = Printers.OCamlr.Make Syntax;
(* module OCamlrr = Printers.OCamlrr.Make Syntax; *)
module DumpOCamlAst = Printers.DumpOCamlAst.Make Syntax;
module DumpCamlp4Ast = Printers.DumpCamlp4Ast.Make Syntax;
module Null = Printers.Null.Make Syntax;
end;

76
camlp4/Camlp4/PreCast.mli
View File

@ -1,76 +0,0 @@
(****************************************************************************)
(* *)
(* OCaml *)
(* *)
(* INRIA Rocquencourt *)
(* *)
(* Copyright 2006 Institut National de Recherche en Informatique et *)
(* en Automatique. All rights reserved. This file is distributed under *)
(* the terms of the GNU Library General Public License, with the special *)
(* exception on linking described in LICENSE at the top of the OCaml *)
(* source tree. *)
(* *)
(****************************************************************************)
(* Authors:
* - Daniel de Rauglaudre: initial version
* - Nicolas Pouillard: refactoring
*)
type camlp4_token = Sig.camlp4_token ==
[ KEYWORD of string
| SYMBOL of string
| LIDENT of string
| UIDENT of string
| ESCAPED_IDENT of string
| INT of int and string
| INT32 of int32 and string
| INT64 of int64 and string
| NATIVEINT of nativeint and string
| FLOAT of float and string
| CHAR of char and string
| STRING of string and string
| LABEL of string
| OPTLABEL of string
| QUOTATION of Sig.quotation
| ANTIQUOT of string and string
| COMMENT of string
| BLANKS of string
| NEWLINE
| LINE_DIRECTIVE of int and option string
| EOI ];
module Id : Sig.Id;
module Loc : Sig.Loc;
module Ast : Sig.Camlp4Ast with module Loc = Loc;
module Token : Sig.Token
with module Loc = Loc
and type t = camlp4_token;
module Lexer : Sig.Lexer
with module Loc = Loc
and module Token = Token;
module Gram : Sig.Grammar.Static
with module Loc = Loc
and module Token = Token;
module Quotation : Sig.Quotation with module Ast = Sig.Camlp4AstToAst Ast;
module DynLoader : Sig.DynLoader;
module AstFilters : Sig.AstFilters with module Ast = Ast;
module Syntax : Sig.Camlp4Syntax
with module Loc = Loc
and module Token = Token
and module Ast = Ast
and module Gram = Gram
and module Quotation = Quotation;
module Printers : sig
module OCaml : (Sig.Printer Ast).S;
module OCamlr : (Sig.Printer Ast).S;
module DumpOCamlAst : (Sig.Printer Ast).S;
module DumpCamlp4Ast : (Sig.Printer Ast).S;
module Null : (Sig.Printer Ast).S;
end;
module MakeGram (Lexer : Sig.Lexer with module Loc = Loc)
: Sig.Grammar.Static with module Loc = Loc and module Token = Lexer.Token;
module MakeSyntax (U : sig end) : Sig.Syntax;

5
camlp4/Camlp4/Printers.mlpack
View File

@ -1,5 +0,0 @@
DumpCamlp4Ast
DumpOCamlAst
Null
OCaml
OCamlr

51
camlp4/Camlp4/Printers/DumpCamlp4Ast.ml
View File

@ -1,51 +0,0 @@
(****************************************************************************)
(* *)
(* OCaml *)
(* *)
(* INRIA Rocquencourt *)
(* *)
(* Copyright 2006 Institut National de Recherche en Informatique et *)
(* en Automatique. All rights reserved. This file is distributed under *)
(* the terms of the GNU Library General Public License, with the special *)
(* exception on linking described in LICENSE at the top of the OCaml *)
(* source tree. *)
(* *)
(****************************************************************************)
(* Authors:
* - Daniel de Rauglaudre: initial version
* - Nicolas Pouillard: refactoring
*)
module Id = struct
value name = "Camlp4Printers.DumpCamlp4Ast";
value version = Sys.ocaml_version;
end;
module Make (Syntax : Sig.Syntax)
: (Sig.Printer Syntax.Ast).S
= struct
include Syntax;
value with_open_out_file x f =
match x with
[ Some file -> do { let oc = open_out_bin file;
f oc;
flush oc;
close_out oc }
| None -> do { set_binary_mode_out stdout True; f stdout; flush stdout } ];
value dump_ast magic ast oc = do {
output_string oc magic;
output_value oc ast;
};
value print_interf ?input_file:(_) ?output_file ast =
with_open_out_file output_file
(dump_ast Camlp4_config.camlp4_ast_intf_magic_number ast);
value print_implem ?input_file:(_) ?output_file ast =
with_open_out_file output_file
(dump_ast Camlp4_config.camlp4_ast_impl_magic_number ast);
end;

21
camlp4/Camlp4/Printers/DumpCamlp4Ast.mli
View File

@ -1,21 +0,0 @@
(****************************************************************************)
(* *)
(* OCaml *)
(* *)
(* INRIA Rocquencourt *)
(* *)
(* Copyright 2006 Institut National de Recherche en Informatique et *)
(* en Automatique. All rights reserved. This file is distributed under *)
(* the terms of the GNU Library General Public License, with the special *)
(* exception on linking described in LICENSE at the top of the OCaml *)
(* source tree. *)
(* *)
(****************************************************************************)
(* Authors:
* - Nicolas Pouillard: initial version
*)
module Id : Sig.Id;
module Make (Syntax : Sig.Syntax) : (Sig.Printer Syntax.Ast).S;

53
camlp4/Camlp4/Printers/DumpOCamlAst.ml
View File

@ -1,53 +0,0 @@
(****************************************************************************)
(* *)
(* OCaml *)
(* *)
(* INRIA Rocquencourt *)
(* *)
(* Copyright 2006 Institut National de Recherche en Informatique et *)
(* en Automatique. All rights reserved. This file is distributed under *)
(* the terms of the GNU Library General Public License, with the special *)
(* exception on linking described in LICENSE at the top of the OCaml *)
(* source tree. *)
(* *)
(****************************************************************************)
(* Authors:
* - Daniel de Rauglaudre: initial version
* - Nicolas Pouillard: refactoring
*)
module Id : Sig.Id = struct
value name = "Camlp4Printers.DumpOCamlAst";
value version = Sys.ocaml_version;
end;
module Make (Syntax : Sig.Camlp4Syntax)
: (Sig.Printer Syntax.Ast).S
= struct
include Syntax;
module Ast2pt = Struct.Camlp4Ast2OCamlAst.Make Ast;
value with_open_out_file x f =
match x with
[ Some file -> do { let oc = open_out_bin file;
f oc;
flush oc;
close_out oc }
| None -> do { set_binary_mode_out stdout True; f stdout; flush stdout } ];
value dump_pt magic fname pt oc = do {
output_string oc magic;
output_value oc (if fname = "-" then "" else fname);
output_value oc pt;
};
value print_interf ?(input_file = "-") ?output_file ast =
let pt = Ast2pt.sig_item ast in
with_open_out_file output_file (dump_pt Camlp4_config.ocaml_ast_intf_magic_number input_file pt);
value print_implem ?(input_file = "-") ?output_file ast =
let pt = Ast2pt.str_item ast in
with_open_out_file output_file (dump_pt Camlp4_config.ocaml_ast_impl_magic_number input_file pt);
end;

21
camlp4/Camlp4/Printers/DumpOCamlAst.mli
View File

@ -1,21 +0,0 @@
(****************************************************************************)
(* *)
(* OCaml *)
(* *)
(* INRIA Rocquencourt *)
(* *)
(* Copyright 2006 Institut National de Recherche en Informatique et *)
(* en Automatique. All rights reserved. This file is distributed under *)
(* the terms of the GNU Library General Public License, with the special *)
(* exception on linking described in LICENSE at the top of the OCaml *)
(* source tree. *)
(* *)
(****************************************************************************)
(* Authors:
* - Nicolas Pouillard: initial version
*)
module Id : Sig.Id;
module Make (Syntax : Sig.Camlp4Syntax) : (Sig.Printer Syntax.Ast).S;

30
camlp4/Camlp4/Printers/Null.ml
View File

@ -1,30 +0,0 @@
(****************************************************************************)
(* *)
(* OCaml *)
(* *)
(* INRIA Rocquencourt *)
(* *)
(* Copyright 2006 Institut National de Recherche en Informatique et *)
(* en Automatique. All rights reserved. This file is distributed under *)
(* the terms of the GNU Library General Public License, with the special *)
(* exception on linking described in LICENSE at the top of the OCaml *)
(* source tree. *)
(* *)
(****************************************************************************)
(* Authors:
* - Daniel de Rauglaudre: initial version
* - Nicolas Pouillard: refactoring
*)
module Id = struct
value name = "Camlp4.Printers.Null";
value version = Sys.ocaml_version;
end;
module Make (Syntax : Sig.Syntax) = struct
include Syntax;
value print_interf ?input_file:(_) ?output_file:(_) _ = ();
value print_implem ?input_file:(_) ?output_file:(_) _ = ();
end;

22
camlp4/Camlp4/Printers/Null.mli
View File

@ -1,22 +0,0 @@
(****************************************************************************)
(* *)
(* OCaml *)
(* *)
(* INRIA Rocquencourt *)
(* *)
(* Copyright 2006 Institut National de Recherche en Informatique et *)
(* en Automatique. All rights reserved. This file is distributed under *)
(* the terms of the GNU Library General Public License, with the special *)
(* exception on linking described in LICENSE at the top of the OCaml *)
(* source tree. *)
(* *)
(****************************************************************************)
(* Authors:
* - Daniel de Rauglaudre: initial version
* - Nicolas Pouillard: refactoring
*)
module Id : Sig.Id;
module Make (Syntax : Sig.Syntax) : (Sig.Printer Syntax.Ast).S;

1174
camlp4/Camlp4/Printers/OCaml.ml
View File

File diff suppressed because it is too large Load Diff

167
camlp4/Camlp4/Printers/OCaml.mli
View File

@ -1,167 +0,0 @@
(****************************************************************************)
(* *)
(* OCaml *)
(* *)
(* INRIA Rocquencourt *)
(* *)
(* Copyright 2006 Institut National de Recherche en Informatique et *)
(* en Automatique. All rights reserved. This file is distributed under *)
(* the terms of the GNU Library General Public License, with the special *)
(* exception on linking described in LICENSE at the top of the OCaml *)
(* source tree. *)
(* *)
(****************************************************************************)
(* Authors:
* - Nicolas Pouillard: initial version
*)
module Id : Sig.Id;
module Make (Syntax : Sig.Camlp4Syntax) : sig
open Format;
include Sig.Camlp4Syntax
with module Loc = Syntax.Loc
and module Token = Syntax.Token
and module Ast = Syntax.Ast
and module Gram = Syntax.Gram;
type sep = format unit formatter unit;
type fun_binding = [= `patt of Ast.patt | `newtype of string ];
value list' :
(formatter -> 'a -> unit) ->
format 'b formatter unit ->
format unit formatter unit ->
formatter -> list 'a -> unit;
value list :
(formatter -> 'a -> unit) ->
format 'b formatter unit ->
formatter -> list 'a -> unit;
value lex_string : string -> Token.t;
value is_infix : string -> bool;
value is_keyword : string -> bool;
value ocaml_char : string -> string;
value get_expr_args :
Ast.expr -> list Ast.expr -> (Ast.expr * list Ast.expr);
value get_patt_args :
Ast.patt -> list Ast.patt -> (Ast.patt * list Ast.patt);
value get_ctyp_args :
Ast.ctyp -> list Ast.ctyp -> (Ast.ctyp * list Ast.ctyp);
value expr_fun_args : Ast.expr -> (list fun_binding * Ast.expr);
(**
[new printer ~curry_constr:True ~comments:False]
Default values: curry_constr = False
comments = True
*)
class printer :
[?curry_constr: bool] -> [?comments: bool] -> [unit] ->
object ('a)
method interf : formatter -> Ast.sig_item -> unit;
method implem : formatter -> Ast.str_item -> unit;
method sig_item : formatter -> Ast.sig_item -> unit;
method str_item : formatter -> Ast.str_item -> unit;
value pipe : bool;
value semi : bool;
value semisep : sep;
value no_semisep : sep;
method value_val : string;
method value_let : string;
method andsep : sep;
method anti : formatter -> string -> unit;
method class_declaration :
formatter -> Ast.class_expr -> unit;
method class_expr : formatter -> Ast.class_expr -> unit;
method class_sig_item :
formatter -> Ast.class_sig_item -> unit;
method class_str_item :
formatter -> Ast.class_str_item -> unit;
method class_type : formatter -> Ast.class_type -> unit;
method constrain :
formatter -> (Ast.ctyp * Ast.ctyp) -> unit;
method ctyp : formatter -> Ast.ctyp -> unit;
method ctyp1 : formatter -> Ast.ctyp -> unit;
method constructor_type : formatter -> Ast.ctyp -> unit;
method dot_expr : formatter -> Ast.expr -> unit;
method apply_expr : formatter -> Ast.expr -> unit;
method expr : formatter -> Ast.expr -> unit;
method expr_list : formatter -> list Ast.expr -> unit;
method expr_list_cons : bool -> formatter -> Ast.expr -> unit;
method fun_binding : formatter -> fun_binding -> unit;
method functor_arg :
formatter -> (string * Ast.module_type) -> unit;
method functor_args :
formatter ->
list (string * Ast.module_type) -> unit;
method ident : formatter -> Ast.ident -> unit;
method numeric : formatter -> string -> string -> unit;
method binding : formatter -> Ast.binding -> unit;
method record_binding : formatter -> Ast.rec_binding -> unit;
method match_case : formatter -> Ast.match_case -> unit;
method match_case_aux : formatter -> Ast.match_case -> unit;
method mk_expr_list : Ast.expr -> (list Ast.expr * option Ast.expr);
method mk_patt_list : Ast.patt -> (list Ast.patt * option Ast.patt);
method simple_module_expr : formatter -> Ast.module_expr -> unit;
method module_expr : formatter -> Ast.module_expr -> unit;
method module_expr_get_functor_args :
list (string * Ast.module_type) ->
Ast.module_expr ->
(list (string * Ast.module_type) *
Ast.module_expr *
option Ast.module_type);
method module_rec_binding : formatter -> Ast.module_binding -> unit;
method module_type : formatter -> Ast.module_type -> unit;
method override_flag : formatter -> Ast.override_flag -> unit;
method mutable_flag : formatter -> Ast.mutable_flag -> unit;
method direction_flag : formatter -> Ast.direction_flag -> unit;
method rec_flag : formatter -> Ast.rec_flag -> unit;
method node : formatter -> 'b -> ('b -> Loc.t) -> unit;
method patt : formatter -> Ast.patt -> unit;
method patt1 : formatter -> Ast.patt -> unit;
method patt2 : formatter -> Ast.patt -> unit;
method patt3 : formatter -> Ast.patt -> unit;
method patt4 : formatter -> Ast.patt -> unit;
method patt5 : formatter -> Ast.patt -> unit;
method patt_tycon : formatter -> Ast.patt -> unit;
method patt_expr_fun_args :
formatter -> (fun_binding * Ast.expr) -> unit;
method patt_class_expr_fun_args :
formatter -> (Ast.patt * Ast.class_expr) -> unit;
method print_comments_before : Loc.t -> formatter -> unit;
method private_flag : formatter -> Ast.private_flag -> unit;
method virtual_flag : formatter -> Ast.virtual_flag -> unit;
method quoted_string : formatter -> string -> unit;
method raise_match_failure : formatter -> Loc.t -> unit;
method reset : 'a;
method reset_semi : 'a;
method semisep : sep;
method set_comments : bool -> 'a;
method set_curry_constr : bool -> 'a;
method set_loc_and_comments : 'a;
method set_semisep : sep -> 'a;
method simple_ctyp : formatter -> Ast.ctyp -> unit;
method simple_expr : formatter -> Ast.expr -> unit;
method simple_patt : formatter -> Ast.patt -> unit;
method seq : formatter -> Ast.expr -> unit;
method string : formatter -> string -> unit;
method sum_type : formatter -> Ast.ctyp -> unit;
method type_params : formatter -> list Ast.ctyp -> unit;
method class_params : formatter -> Ast.ctyp -> unit;
method under_pipe : 'a;
method under_semi : 'a;
method var : formatter -> string -> unit;
method with_constraint : formatter -> Ast.with_constr -> unit;
end;
value with_outfile :
option string -> (formatter -> 'a -> unit) -> 'a -> unit;
value print :
option string -> (printer -> formatter -> 'a -> unit) -> 'a -> unit;
end;
module MakeMore (Syntax : Sig.Camlp4Syntax) : (Sig.Printer Syntax.Ast).S;

324
camlp4/Camlp4/Printers/OCamlr.ml
View File

@ -1,324 +0,0 @@
(****************************************************************************)
(* *)
(* OCaml *)
(* *)
(* INRIA Rocquencourt *)
(* *)
(* Copyright 2006 Institut National de Recherche en Informatique et *)
(* en Automatique. All rights reserved. This file is distributed under *)
(* the terms of the GNU Library General Public License, with the special *)
(* exception on linking described in LICENSE at the top of the OCaml *)
(* source tree. *)
(* *)
(****************************************************************************)
(* Authors:
* - Nicolas Pouillard: initial version
*)
open Format;
module Id = struct
value name = "Camlp4.Printers.OCamlr";
value version = Sys.ocaml_version;
end;
module Make (Syntax : Sig.Camlp4Syntax) = struct
include Syntax;
open Sig;
module PP_o = OCaml.Make Syntax;
open PP_o;
value pp = fprintf;
value is_keyword =
let keywords = ["where"]
and not_keywords = ["false"; "function"; "true"; "val"]
in fun s -> not (List.mem s not_keywords)
&& (is_keyword s || List.mem s keywords);
class printer ?curry_constr:(init_curry_constr = True) ?(comments = True) () =
object (o)
inherit PP_o.printer ~curry_constr:init_curry_constr ~comments () as super;
value! semisep : sep = ";";
value! no_semisep : sep = ";";
value mode = if comments then `comments else `no_comments;
value curry_constr = init_curry_constr;
value first_match_case = True;
method andsep : sep = "@]@ @[<2>and@ ";
method value_val = "value";
method value_let = "value";
method under_pipe = o;
method under_semi = o;
method reset_semi = o;
method reset = o;
method private unset_first_match_case = {< first_match_case = False >};
method private set_first_match_case = {< first_match_case = True >};
method seq f e =
let rec self right f e =
let go_right = self right and go_left = self False in
match e with
[ <:expr< let $rec:r$ $bi$ in $e1$ >> ->
if right then
pp f "@[<2>let %a%a@];@ %a"
o#rec_flag r o#binding bi go_right e1
else
pp f "(%a)" o#expr e
| <:expr< do { $e$ } >> -> go_right f e
| <:expr< $e1$; $e2$ >> -> do {
pp f "%a;@ " go_left e1;
match (right, e2) with
[ (True, <:expr< let $rec:r$ $bi$ in $e3$ >>) ->
pp f "@[<2>let %a%a@];@ %a"
o#rec_flag r o#binding bi go_right e3
| _ -> go_right f e2 ] }
| e -> o#expr f e ]
in self True f e;
method var f =
fun
[ "" -> pp f "$lid:\"\"$"
| "[]" -> pp f "[]"
| "()" -> pp f "()"
| " True" -> pp f "True"
| " False" -> pp f "False"
| v ->
match lex_string v with
[ (LIDENT s | UIDENT s | ESCAPED_IDENT s) when is_keyword s ->
pp f "%s__" s
| SYMBOL s ->
pp f "( %s )" s
| LIDENT s | UIDENT s | ESCAPED_IDENT s ->
pp_print_string f s
| tok -> failwith (sprintf
"Bad token used as an identifier: %s"
(Token.to_string tok)) ] ];
method type_params f =
fun
[ [] -> ()
| [x] -> pp f "@ %a" o#ctyp x
| l -> pp f "@ @[<1>%a@]" (list o#ctyp "@ ") l ];
method match_case f =
fun
[ <:match_case<>> -> pp f "@ []"
| m -> pp f "@ [ %a ]" o#set_first_match_case#match_case_aux m ];
method match_case_aux f =
fun
[ <:match_case<>> -> ()
| <:match_case< $anti:s$ >> -> o#anti f s
| <:match_case< $a1$ | $a2$ >> ->
pp f "%a%a" o#match_case_aux a1 o#unset_first_match_case#match_case_aux a2
| <:match_case< $p$ -> $e$ >> ->
let () = if first_match_case then () else pp f "@ | " in
pp f "@[<2>%a@ ->@ %a@]" o#patt p o#under_pipe#expr e
| <:match_case< $p$ when $w$ -> $e$ >> ->
let () = if first_match_case then () else pp f "@ | " in
pp f "@[<2>%a@ when@ %a@ ->@ %a@]"
o#patt p o#under_pipe#expr w o#under_pipe#expr e ];
method sum_type f =
fun
[ <:ctyp<>> -> pp f "[]"
| t -> pp f "@[<hv0>[ %a ]@]" o#ctyp t
];
method ident f i =
let () = o#node f i Ast.loc_of_ident in
match i with
[ <:ident< $i1$ $i2$ >> -> pp f "%a@ %a" o#dot_ident i1 o#dot_ident i2
| i -> o#dot_ident f i ];
method private dot_ident f i =
let () = o#node f i Ast.loc_of_ident in
match i with
[ <:ident< $i1$.$i2$ >> -> pp f "%a.@,%a" o#dot_ident i1 o#dot_ident i2
| <:ident< $anti:s$ >> -> o#anti f s
| <:ident< $lid:s$ >> | <:ident< $uid:s$ >> -> o#var f s
| i -> pp f "(%a)" o#ident i ];
method patt4 f = fun
[ <:patt< [$_$ :: $_$] >> as p ->
let (pl, c) = o#mk_patt_list p in
match c with
[ None -> pp f "@[<2>[@ %a@]@ ]" (list o#patt ";@ ") pl
| Some x -> pp f "@[<2>[ %a ::@ %a ]@]" (list o#patt ";@ ") pl o#patt x ]
| p -> super#patt4 f p ];
method expr_list_cons _ f e =
let (el, c) = o#mk_expr_list e in
match c with
[ None -> o#expr_list f el
| Some x -> pp f "@[<2>[ %a ::@ %a ]@]" (list o#expr ";@ ") el o#expr x ];
method expr f e =
let () = o#node f e Ast.loc_of_expr in
match e with
[ <:expr< $e1$ := $e2$ >> ->
pp f "@[<2>%a@ :=@ %a@]" o#dot_expr e1 o#expr e2
| <:expr< fun $p$ -> $e$ >> when Ast.is_irrefut_patt p ->
pp f "@[<2>fun@ %a@]" o#patt_expr_fun_args (`patt p, e)
| <:expr< fun (type $i$) -> $e$ >> ->
pp f "@[<2>fun@ %a@]" o#patt_expr_fun_args (`newtype i, e)
| <:expr< fun [ $a$ ] >> ->
pp f "@[<hv0>fun%a@]" o#match_case a
| <:expr< assert False >> -> pp f "@[<2>assert@ False@]"
| e -> super#expr f e ];
method dot_expr f e =
let () = o#node f e Ast.loc_of_expr in
match e with
[ <:expr< $e$.val >> -> pp f "@[<2>%a.@,val@]" o#simple_expr e
| e -> super#dot_expr f e ];
method ctyp f t =
let () = o#node f t Ast.loc_of_ctyp in
match t with
[ Ast.TyDcl _ tn tp te cl -> do {
pp f "@[<2>%a%a@]" o#var tn o#type_params tp;
match te with
[ <:ctyp<>> -> ()
| _ -> pp f " =@ %a" o#ctyp te ];
if cl <> [] then pp f "@ %a" (list o#constrain "@ ") cl else ();
}
| <:ctyp< $t1$ : mutable $t2$ >> ->
pp f "@[%a :@ mutable %a@]" o#ctyp t1 o#ctyp t2
| <:ctyp< $t1$ == $t2$ >> ->
pp f "@[<2>%a ==@ %a@]" o#simple_ctyp t1 o#ctyp t2
| t -> super#ctyp f t ];
method simple_ctyp f t =
let () = o#node f t Ast.loc_of_ctyp in
match t with
[ <:ctyp< [ = $t$ ] >> -> pp f "@[<2>[ =@ %a@]@ ]" o#ctyp t
| <:ctyp< [ < $t$ ] >> -> pp f "@[<2>[ <@ %a@]@,]" o#ctyp t
| <:ctyp< [ < $t1$ > $t2$ ] >> ->
pp f "@[<2>[ <@ %a@ >@ %a@]@ ]" o#ctyp t1 o#ctyp t2
| <:ctyp< [ > $t$ ] >> -> pp f "@[<2>[ >@ %a@]@,]" o#ctyp t
| <:ctyp< $t1$ == $t2$ >> ->
pp f "@[<2>%a@ ==@ %a@]" o#simple_ctyp t1 o#simple_ctyp t2
| <:ctyp< ~ $s$ : $t$ >> -> pp f "@[<2>~%s:@ %a@]" s o#simple_ctyp t
| t -> super#simple_ctyp f t ];
method ctyp1 f = fun
[ <:ctyp< $t1$ $t2$ >> ->
match get_ctyp_args t1 [t2] with
[ (_, [_]) -> pp f "@[<2>%a@ %a@]" o#simple_ctyp t1 o#simple_ctyp t2
| (a, al) -> pp f "@[<2>%a@]" (list o#simple_ctyp "@ ") [a::al] ]
| <:ctyp< ! $t1$ . $t2$ >> ->
let (a, al) = get_ctyp_args t1 [] in
pp f "@[<2>! %a.@ %a@]" (list o#ctyp "@ ") [a::al] o#ctyp t2
| t -> super#ctyp1 f t ];
method constructor_type f t =
match t with
[ <:ctyp@loc< $t1$ and $t2$ >> ->
let () = o#node f t (fun _ -> loc) in
pp f "%a@ and %a" o#constructor_type t1 o#constructor_type t2
| t -> o#ctyp f t ];
method str_item f st =
match st with
[ <:str_item< $exp:e$ >> -> pp f "@[<2>%a%(%)@]" o#expr e semisep
| st -> super#str_item f st ];
method module_expr f me =
let () = o#node f me Ast.loc_of_module_expr in
match me with
[ <:module_expr< $me1$ $me2$ >> ->
pp f "@[<2>%a@ %a@]" o#module_expr me1 o#simple_module_expr me2
| me -> super#module_expr f me ];
method simple_module_expr f me =
let () = o#node f me Ast.loc_of_module_expr in
match me with
[ <:module_expr< $_$ $_$ >> ->
pp f "(%a)" o#module_expr me
| _ -> super#simple_module_expr f me ];
method implem f st = pp f "@[<v0>%a@]@." o#str_item st;
method class_type f ct =
let () = o#node f ct Ast.loc_of_class_type in
match ct with
[ <:class_type< [ $t$ ] -> $ct$ >> ->
pp f "@[<2>[ %a ] ->@ %a@]" o#simple_ctyp t o#class_type ct
| <:class_type< $id:i$ >> ->
pp f "@[<2>%a@]" o#ident i
| <:class_type< $id:i$ [ $t$ ] >> ->
pp f "@[<2>%a [@,%a@]@,]" o#ident i o#class_params t
| <:class_type< virtual $lid:i$ >> ->
pp f "@[<2>virtual@ %a@]" o#var i
| <:class_type< virtual $lid:i$ [ $t$ ] >> ->
pp f "@[<2>virtual@ %a@ [@,%a@]@,]" o#var i o#class_params t
| ct -> super#class_type f ct ];
method class_expr f ce =
let () = o#node f ce Ast.loc_of_class_expr in
match ce with
[ <:class_expr< $id:i$ >> ->
pp f "@[<2>%a@]" o#ident i
| <:class_expr< $id:i$ [ $t$ ] >> ->
pp f "@[<2>%a@ @[<1>[%a]@]@]" o#ident i o#class_params t
| <:class_expr< virtual $lid:i$ >> ->
pp f "@[<2>virtual@ %a@]" o#var i
| <:class_expr< virtual $lid:i$ [ $t$ ] >> ->
pp f "@[<2>virtual@ %a@ @[<1>[%a]@]@]" o#var i o#class_params t
| ce -> super#class_expr f ce ];
end;
value with_outfile = with_outfile;
value print output_file fct =
let o = new printer () in
with_outfile output_file (fct o);
value print_interf ?input_file:(_) ?output_file sg =
print output_file (fun o -> o#interf) sg;
value print_implem ?input_file:(_) ?output_file st =
print output_file (fun o -> o#implem) st;
end;
module MakeMore (Syntax : Sig.Camlp4Syntax)
: (Sig.Printer Syntax.Ast).S
= struct
include Make Syntax;
value margin = ref 78;
value comments = ref True;
value locations = ref False;
value curry_constr = ref True;
value print output_file fct =
let o = new printer ~comments:comments.val
~curry_constr:curry_constr.val () in
let o = if locations.val then o#set_loc_and_comments else o in
with_outfile output_file
(fun f ->
let () = Format.pp_set_margin f margin.val in
Format.fprintf f "@[<v0>%a@]@." (fct o));
value print_interf ?input_file:(_) ?output_file sg =
print output_file (fun o -> o#interf) sg;
value print_implem ?input_file:(_) ?output_file st =
print output_file (fun o -> o#implem) st;
Options.add "-l" (Arg.Int (fun i -> margin.val := i))
"<length> line length for pretty printing.";
Options.add "-no_comments" (Arg.Clear comments) "Do not add comments.";
Options.add "-add_locations" (Arg.Set locations) "Add locations as comment.";
end;

47
camlp4/Camlp4/Printers/OCamlr.mli
View File

@ -1,47 +0,0 @@
(****************************************************************************)
(* *)
(* OCaml *)
(* *)
(* INRIA Rocquencourt *)
(* *)
(* Copyright 2006 Institut National de Recherche en Informatique et *)
(* en Automatique. All rights reserved. This file is distributed under *)
(* the terms of the GNU Library General Public License, with the special *)
(* exception on linking described in LICENSE at the top of the OCaml *)
(* source tree. *)
(* *)
(****************************************************************************)
(* Authors:
* - Nicolas Pouillard: initial version
*)
module Id : Sig.Id;
module Make (Syntax : Sig.Camlp4Syntax) : sig
open Format;
include Sig.Camlp4Syntax
with module Loc = Syntax.Loc
and module Token = Syntax.Token
and module Ast = Syntax.Ast
and module Gram = Syntax.Gram;
(**
[new printer ~curry_constr:c ~comments:False]
Default values: curry_constr = True
comments = True
*)
class printer :
[?curry_constr: bool] -> [?comments: bool] -> [unit] ->
object ('a)
inherit (OCaml.Make Syntax).printer;
end;
value with_outfile :
option string -> (formatter -> 'a -> unit) -> 'a -> unit;
value print :
option string -> (printer -> formatter -> 'a -> unit) -> 'a -> unit;
end;
module MakeMore (Syntax : Sig.Camlp4Syntax) : (Sig.Printer Syntax.Ast).S;

171
camlp4/Camlp4/Register.ml
View File

@ -1,171 +0,0 @@
(****************************************************************************)
(* *)
(* OCaml *)
(* *)
(* INRIA Rocquencourt *)
(* *)
(* Copyright 2006 Institut National de Recherche en Informatique et *)
(* en Automatique. All rights reserved. This file is distributed under *)
(* the terms of the GNU Library General Public License, with the special *)
(* exception on linking described in LICENSE at the top of the OCaml *)
(* source tree. *)
(* *)
(****************************************************************************)
(* Authors:
* - Daniel de Rauglaudre: initial version
* - Nicolas Pouillard: refactoring
*)
module PP = Printers;
open PreCast;
type parser_fun 'a =
?directive_handler:('a -> option 'a) -> PreCast.Loc.t -> Stream.t char -> 'a;
type printer_fun 'a =
?input_file:string -> ?output_file:string -> 'a -> unit;
value sig_item_parser = ref (fun ?directive_handler:(_) _ _ -> failwith "No interface parser");
value str_item_parser = ref (fun ?directive_handler:(_) _ _ -> failwith "No implementation parser");
value sig_item_printer = ref (fun ?input_file:(_) ?output_file:(_) _ -> failwith "No interface printer");
value str_item_printer = ref (fun ?input_file:(_) ?output_file:(_) _ -> failwith "No implementation printer");
value callbacks = Queue.create ();
value loaded_modules = ref [];
value iter_and_take_callbacks f =
let rec loop () = loop (f (Queue.take callbacks)) in
try loop () with [ Queue.Empty -> () ];
value declare_dyn_module m f =
begin
(* let () = Format.eprintf "declare_dyn_module: %s@." m in *)
loaded_modules.val := [ m :: loaded_modules.val ];
Queue.add (m, f) callbacks;
end;
value register_str_item_parser f = str_item_parser.val := f;
value register_sig_item_parser f = sig_item_parser.val := f;
value register_parser f g =
do { str_item_parser.val := f; sig_item_parser.val := g };
value current_parser () = (str_item_parser.val, sig_item_parser.val);
value register_str_item_printer f = str_item_printer.val := f;
value register_sig_item_printer f = sig_item_printer.val := f;
value register_printer f g =
do { str_item_printer.val := f; sig_item_printer.val := g };
value current_printer () = (str_item_printer.val, sig_item_printer.val);
module Plugin (Id : Sig.Id) (Maker : functor (Unit : sig end) -> sig end) = struct
declare_dyn_module Id.name (fun _ -> let module M = Maker (struct end) in ());
end;
module SyntaxExtension (Id : Sig.Id) (Maker : Sig.SyntaxExtension) = struct
declare_dyn_module Id.name (fun _ -> let module M = Maker Syntax in ());
end;
module OCamlSyntaxExtension
(Id : Sig.Id) (Maker : functor (Syn : Sig.Camlp4Syntax) -> Sig.Camlp4Syntax) =
struct
declare_dyn_module Id.name (fun _ -> let module M = Maker Syntax in ());
end;
module SyntaxPlugin (Id : Sig.Id) (Maker : functor (Syn : Sig.Syntax) -> sig end) = struct
declare_dyn_module Id.name (fun _ -> let module M = Maker Syntax in ());
end;
module Printer
(Id : Sig.Id) (Maker : functor (Syn : Sig.Syntax)
-> (Sig.Printer Syn.Ast).S) =
struct
declare_dyn_module Id.name (fun _ ->
let module M = Maker Syntax in
register_printer M.print_implem M.print_interf);
end;
module OCamlPrinter
(Id : Sig.Id) (Maker : functor (Syn : Sig.Camlp4Syntax)
-> (Sig.Printer Syn.Ast).S) =
struct
declare_dyn_module Id.name (fun _ ->
let module M = Maker Syntax in
register_printer M.print_implem M.print_interf);
end;
module OCamlPreCastPrinter
(Id : Sig.Id) (P : (Sig.Printer PreCast.Ast).S) =
struct
declare_dyn_module Id.name (fun _ ->
register_printer P.print_implem P.print_interf);
end;
module Parser
(Id : Sig.Id) (Maker : functor (Ast : Sig.Ast)
-> (Sig.Parser Ast).S) =
struct
declare_dyn_module Id.name (fun _ ->
let module M = Maker PreCast.Ast in
register_parser M.parse_implem M.parse_interf);
end;
module OCamlParser
(Id : Sig.Id) (Maker : functor (Ast : Sig.Camlp4Ast)
-> (Sig.Parser Ast).S) =
struct
declare_dyn_module Id.name (fun _ ->
let module M = Maker PreCast.Ast in
register_parser M.parse_implem M.parse_interf);
end;
module OCamlPreCastParser
(Id : Sig.Id) (P : (Sig.Parser PreCast.Ast).S) =
struct
declare_dyn_module Id.name (fun _ ->
register_parser P.parse_implem P.parse_interf);
end;
module AstFilter
(Id : Sig.Id) (Maker : functor (F : Sig.AstFilters) -> sig end) =
struct
declare_dyn_module Id.name (fun _ -> let module M = Maker AstFilters in ());
end;
sig_item_parser.val := Syntax.parse_interf;
str_item_parser.val := Syntax.parse_implem;
module CurrentParser = struct
module Ast = Ast;
value parse_interf ?directive_handler loc strm =
sig_item_parser.val ?directive_handler loc strm;
value parse_implem ?directive_handler loc strm =
str_item_parser.val ?directive_handler loc strm;
end;
module CurrentPrinter = struct
module Ast = Ast;
value print_interf ?input_file ?output_file ast =
sig_item_printer.val ?input_file ?output_file ast;
value print_implem ?input_file ?output_file ast =
str_item_printer.val ?input_file ?output_file ast;
end;
value enable_ocaml_printer () =
let module M = OCamlPrinter PP.OCaml.Id PP.OCaml.MakeMore in ();
value enable_ocamlr_printer () =
let module M = OCamlPrinter PP.OCamlr.Id PP.OCamlr.MakeMore in ();
(* value enable_ocamlrr_printer () =
let module M = OCamlPrinter PP.OCamlrr.Id PP.OCamlrr.MakeMore in (); *)
value enable_dump_ocaml_ast_printer () =
let module M = OCamlPrinter PP.DumpOCamlAst.Id PP.DumpOCamlAst.Make in ();
value enable_dump_camlp4_ast_printer () =
let module M = Printer PP.DumpCamlp4Ast.Id PP.DumpCamlp4Ast.Make in ();
value enable_null_printer () =
let module M = Printer PP.Null.Id PP.Null.Make in ();

95
camlp4/Camlp4/Register.mli
View File

@ -1,95 +0,0 @@
(****************************************************************************)
(* *)
(* OCaml *)
(* *)
(* INRIA Rocquencourt *)
(* *)
(* Copyright 2006 Institut National de Recherche en Informatique et *)
(* en Automatique. All rights reserved. This file is distributed under *)
(* the terms of the GNU Library General Public License, with the special *)
(* exception on linking described in LICENSE at the top of the OCaml *)
(* source tree. *)
(* *)
(****************************************************************************)
(* Authors:
* - Daniel de Rauglaudre: initial version
* - Nicolas Pouillard: refactoring
*)
module Plugin
(Id : Sig.Id) (Plugin : functor (Unit : sig end) -> sig end) : sig end;
module SyntaxPlugin
(Id : Sig.Id) (SyntaxPlugin : functor (Syn : Sig.Syntax) -> sig end) :
sig end;
module SyntaxExtension
(Id : Sig.Id) (SyntaxExtension : Sig.SyntaxExtension) : sig end;
module OCamlSyntaxExtension
(Id : Sig.Id)
(SyntaxExtension : functor (Syntax : Sig.Camlp4Syntax) -> Sig.Camlp4Syntax)
: sig end;
(** {6 Registering Parsers} *)
type parser_fun 'a =
?directive_handler:('a -> option 'a) -> PreCast.Loc.t -> Stream.t char -> 'a;
value register_str_item_parser : parser_fun PreCast.Ast.str_item -> unit;
value register_sig_item_parser : parser_fun PreCast.Ast.sig_item -> unit;
value register_parser : parser_fun PreCast.Ast.str_item -> parser_fun PreCast.Ast.sig_item -> unit;
value current_parser : unit -> (parser_fun PreCast.Ast.str_item * parser_fun PreCast.Ast.sig_item);
module Parser
(Id : Sig.Id) (Maker : functor (Ast : Sig.Ast) -> (Sig.Parser Ast).S) : sig end;
module OCamlParser
(Id : Sig.Id) (Maker : functor (Ast : Sig.Camlp4Ast) -> (Sig.Parser Ast).S) : sig end;
module OCamlPreCastParser
(Id : Sig.Id) (Parser : (Sig.Parser PreCast.Ast).S) : sig end;
(** {6 Registering Printers} *)
type printer_fun 'a =
?input_file:string -> ?output_file:string -> 'a -> unit;
value register_str_item_printer : printer_fun PreCast.Ast.str_item -> unit;
value register_sig_item_printer : printer_fun PreCast.Ast.sig_item -> unit;
value register_printer : printer_fun PreCast.Ast.str_item -> printer_fun PreCast.Ast.sig_item -> unit;
value current_printer : unit -> (printer_fun PreCast.Ast.str_item * printer_fun PreCast.Ast.sig_item);
module Printer
(Id : Sig.Id)
(Maker : functor (Syn : Sig.Syntax) -> (Sig.Printer Syn.Ast).S) :
sig end;
module OCamlPrinter
(Id : Sig.Id)
(Maker : functor (Syn : Sig.Camlp4Syntax) -> (Sig.Printer Syn.Ast).S) :
sig end;
module OCamlPreCastPrinter
(Id : Sig.Id) (Printer : (Sig.Printer PreCast.Ast).S) :
sig end;
(** {6 Registering Filters} *)
module AstFilter
(Id : Sig.Id) (Maker : functor (F : Sig.AstFilters) -> sig end) : sig end;
value declare_dyn_module : string -> (unit -> unit) -> unit;
value iter_and_take_callbacks : ((string * (unit -> unit)) -> unit) -> unit;
value loaded_modules : ref (list string);
module CurrentParser : (Sig.Parser PreCast.Ast).S;
module CurrentPrinter : (Sig.Printer PreCast.Ast).S;
value enable_ocaml_printer : unit -> unit;
value enable_ocamlr_printer : unit -> unit;
(* value enable_ocamlrr_printer : unit -> unit; *)
value enable_null_printer : unit -> unit;
value enable_dump_ocaml_ast_printer : unit -> unit;
value enable_dump_camlp4_ast_printer : unit -> unit;

1445
camlp4/Camlp4/Sig.ml
View File

File diff suppressed because it is too large Load Diff

15
camlp4/Camlp4/Struct.mlpack
View File

@ -1,15 +0,0 @@
AstFilters
Camlp4Ast
Camlp4Ast2OCamlAst
CleanAst
CommentFilter
DynLoader
EmptyError
EmptyPrinter
FreeVars
Lexer
Loc
Quotation
Token
Grammar
DynAst

2
camlp4/Camlp4/Struct/.ignore
View File

@ -1,2 +0,0 @@
Lexer.ml
Camlp4Ast.tmp.ml

37
camlp4/Camlp4/Struct/AstFilters.ml
View File

@ -1,37 +0,0 @@
(****************************************************************************)
(* *)
(* OCaml *)
(* *)
(* INRIA Rocquencourt *)
(* *)
(* Copyright 2006 Institut National de Recherche en Informatique et *)
(* en Automatique. All rights reserved. This file is distributed under *)
(* the terms of the GNU Library General Public License, with the special *)
(* exception on linking described in LICENSE at the top of the OCaml *)
(* source tree. *)
(* *)
(****************************************************************************)
(* Authors:
* - Daniel de Rauglaudre: initial version
* - Nicolas Pouillard: refactoring
*)
module Make (Ast : Sig.Camlp4Ast)
: Sig.AstFilters with module Ast = Ast
= struct
module Ast = Ast;
type filter 'a = 'a -> 'a;
value interf_filters = Queue.create ();
value fold_interf_filters f i = Queue.fold f i interf_filters;
value implem_filters = Queue.create ();
value fold_implem_filters f i = Queue.fold f i implem_filters;
value topphrase_filters = Queue.create ();
value fold_topphrase_filters f i = Queue.fold f i topphrase_filters;
value register_sig_item_filter f = Queue.add f interf_filters;
value register_str_item_filter f = Queue.add f implem_filters;
value register_topphrase_filter f = Queue.add f topphrase_filters;
end;

545
camlp4/Camlp4/Struct/Camlp4Ast.mlast
View File

@ -1,545 +0,0 @@
(****************************************************************************)
(* *)
(* OCaml *)
(* *)
(* INRIA Rocquencourt *)
(* *)
(* Copyright 2006 Institut National de Recherche en Informatique et *)
(* en Automatique. All rights reserved. This file is distributed under *)
(* the terms of the GNU Library General Public License, with the special *)
(* exception on linking described in LICENSE at the top of the OCaml *)
(* source tree. *)
(* *)
(****************************************************************************)
(* Authors:
* - Daniel de Rauglaudre: initial version
* - Nicolas Pouillard: refactoring
*)
module Make (Loc : Sig.Loc)
: Sig.Camlp4Ast with module Loc = Loc
= struct
module Loc = Loc;
module Ast = struct
include Sig.MakeCamlp4Ast Loc;
value safe_string_escaped s =
if String.length s > 2 && s.[0] = '\\' && s.[1] = '$' then s
else String.escaped s;
end;
include Ast;
external loc_of_ctyp : ctyp -> Loc.t = "%field0";
external loc_of_patt : patt -> Loc.t = "%field0";
external loc_of_expr : expr -> Loc.t = "%field0";
external loc_of_module_type : module_type -> Loc.t = "%field0";
external loc_of_module_expr : module_expr -> Loc.t = "%field0";
external loc_of_sig_item : sig_item -> Loc.t = "%field0";
external loc_of_str_item : str_item -> Loc.t = "%field0";
external loc_of_class_type : class_type -> Loc.t = "%field0";
external loc_of_class_sig_item : class_sig_item -> Loc.t = "%field0";
external loc_of_class_expr : class_expr -> Loc.t = "%field0";
external loc_of_class_str_item : class_str_item -> Loc.t = "%field0";
external loc_of_with_constr : with_constr -> Loc.t = "%field0";
external loc_of_binding : binding -> Loc.t = "%field0";
external loc_of_rec_binding : rec_binding -> Loc.t = "%field0";
external loc_of_module_binding : module_binding -> Loc.t = "%field0";
external loc_of_match_case : match_case -> Loc.t = "%field0";
external loc_of_ident : ident -> Loc.t = "%field0";
value ghost = Loc.ghost;
value rec is_module_longident =
fun
[ <:ident< $_$.$i$ >> -> is_module_longident i
| <:ident< $i1$ $i2$ >> ->
is_module_longident i1 && is_module_longident i2
| <:ident< $uid:_$ >> -> True
| _ -> False ];
value ident_of_expr =
let error () =
invalid_arg "ident_of_expr: this expression is not an identifier" in
let rec self =
fun
[ <:expr@_loc< $e1$ $e2$ >> -> <:ident< $self e1$ $self e2$ >>
| <:expr@_loc< $e1$.$e2$ >> -> <:ident< $self e1$.$self e2$ >>
| <:expr< $lid:_$ >> -> error ()
| <:expr< $id:i$ >> -> if is_module_longident i then i else error ()
| _ -> error () ] in
fun
[ <:expr< $id:i$ >> -> i
| <:expr< $_$ $_$ >> -> error ()
| t -> self t ];
value ident_of_ctyp =
let error () =
invalid_arg "ident_of_ctyp: this type is not an identifier" in
let rec self =
fun
[ <:ctyp@_loc< $t1$ $t2$ >> -> <:ident< $self t1$ $self t2$ >>
| <:ctyp< $lid:_$ >> -> error ()
| <:ctyp< $id:i$ >> -> if is_module_longident i then i else error ()
| _ -> error () ] in
fun
[ <:ctyp< $id:i$ >> -> i
| t -> self t ];
value ident_of_patt =
let error () =
invalid_arg "ident_of_patt: this pattern is not an identifier" in
let rec self =
fun
[ <:patt@_loc< $p1$ $p2$ >> -> <:ident< $self p1$ $self p2$ >>
| <:patt< $lid:_$ >> -> error ()
| <:patt< $id:i$ >> -> if is_module_longident i then i else error ()
| _ -> error () ] in
fun
[ <:patt< $id:i$ >> -> i
| p -> self p ];
value rec is_irrefut_patt =
fun
[ <:patt< $lid:_$ >> -> True
| <:patt< () >> -> True
| <:patt< _ >> -> True
| <:patt<>> -> True (* why not *)
| <:patt< ($x$ as $y$) >> -> is_irrefut_patt x && is_irrefut_patt y
| <:patt< { $p$ } >> -> is_irrefut_patt p
| <:patt< $_$ = $p$ >> -> is_irrefut_patt p
| <:patt< $p1$; $p2$ >> -> is_irrefut_patt p1 && is_irrefut_patt p2
| <:patt< $p1$, $p2$ >> -> is_irrefut_patt p1 && is_irrefut_patt p2
| <:patt< $p1$ | $p2$ >> -> is_irrefut_patt p1 && is_irrefut_patt p2 (* could be more fine grained *)
| <:patt< $p1$ $p2$ >> -> is_irrefut_patt p1 && is_irrefut_patt p2
| <:patt< ($p$ : $_$) >> -> is_irrefut_patt p
| <:patt< ($tup:pl$) >> -> is_irrefut_patt pl
| <:patt< ? $_$ >> -> True
| <:patt< ? $_$ : ($p$) >> -> is_irrefut_patt p
| <:patt< ? $_$ : ($p$ = $_$) >> -> is_irrefut_patt p
| <:patt< ~ $_$ >> -> True
| <:patt< ~ $_$ : $p$ >> -> is_irrefut_patt p
| <:patt< lazy $p$ >> -> is_irrefut_patt p
| Ast.PaAtt _loc _s _str p -> is_irrefut_patt p
| <:patt< $id:_$ >> -> False (* here one need to know the arity of constructors *)
| <:patt< (module $_$) >> -> True
| <:patt< `$_$ >> | <:patt< $str:_$ >> | <:patt< $_$ .. $_$ >> |
<:patt< $flo:_$ >> | <:patt< $nativeint:_$ >> | <:patt< $int64:_$ >> |
<:patt< $int32:_$ >> | <:patt< $int:_$ >> | <:patt< $chr:_$ >> |
<:patt< #$_$ >> | <:patt< [| $_$ |] >> | <:patt< $anti:_$ >> -> False
];
value rec is_constructor =
fun
[ <:ident< $_$.$i$ >> -> is_constructor i
| <:ident< $uid:_$ >> -> True
| <:ident< $lid:_$ >> | <:ident< $_$ $_$ >> -> False
| <:ident< $anti:_$ >> -> assert False ];
value is_patt_constructor =
fun
[ <:patt< $id:i$ >> -> is_constructor i
| <:patt< `$_$ >> -> True
| _ -> False ];
value rec is_expr_constructor =
fun
[ <:expr< $id:i$ >> -> is_constructor i
| <:expr< $e1$.$e2$ >> -> is_expr_constructor e1 && is_expr_constructor e2
| <:expr< `$_$ >> -> True
| _ -> False ];
value rec tyOr_of_list =
fun
[ [] -> <:ctyp@ghost<>>
| [t] -> t
| [t::ts] ->
let _loc = loc_of_ctyp t in <:ctyp< $t$ | $tyOr_of_list ts$ >> ];
value rec tyAnd_of_list =
fun
[ [] -> <:ctyp@ghost<>>
| [t] -> t
| [t::ts] ->
let _loc = loc_of_ctyp t in <:ctyp< $t$ and $tyAnd_of_list ts$ >> ];
value rec tySem_of_list =
fun
[ [] -> <:ctyp@ghost<>>
| [t] -> t
| [t::ts] ->
let _loc = loc_of_ctyp t in <:ctyp< $t$ ; $tySem_of_list ts$ >> ];
value rec tyCom_of_list =
fun
[ [] -> <:ctyp@ghost<>>
| [t] -> t
| [t::ts] ->
let _loc = loc_of_ctyp t in <:ctyp< $t$, $tyCom_of_list ts$ >> ];
value rec tyAmp_of_list =
fun
[ [] -> <:ctyp@ghost<>>
| [t] -> t
| [t::ts] ->
let _loc = loc_of_ctyp t in <:ctyp< $t$ & $tyAmp_of_list ts$ >> ];
value rec tySta_of_list =
fun
[ [] -> <:ctyp@ghost<>>
| [t] -> t
| [t::ts] ->
let _loc = loc_of_ctyp t in <:ctyp< $t$ * $tySta_of_list ts$ >> ];
value rec stSem_of_list =
fun
[ [] -> <:str_item@ghost<>>
| [t] -> t
| [t::ts] ->
let _loc = loc_of_str_item t in <:str_item< $t$ ; $stSem_of_list ts$ >> ];
value rec sgSem_of_list =
fun
[ [] -> <:sig_item@ghost<>>
| [t] -> t
| [t::ts] ->
let _loc = loc_of_sig_item t in <:sig_item< $t$ ; $sgSem_of_list ts$ >> ];
value rec biAnd_of_list =
fun
[ [] -> <:binding@ghost<>>
| [b] -> b
| [b::bs] ->
let _loc = loc_of_binding b in <:binding< $b$ and $biAnd_of_list bs$ >> ];
value rec rbSem_of_list =
fun
[ [] -> <:rec_binding@ghost<>>
| [b] -> b
| [b::bs] ->
let _loc = loc_of_rec_binding b in
<:rec_binding< $b$; $rbSem_of_list bs$ >> ];
value rec wcAnd_of_list =
fun
[ [] -> <:with_constr@ghost<>>
| [w] -> w
| [w::ws] ->
let _loc = loc_of_with_constr w in
<:with_constr< $w$ and $wcAnd_of_list ws$ >> ];
value rec idAcc_of_list =
fun
[ [] -> assert False
| [i] -> i
| [i::is] ->
let _loc = loc_of_ident i in
<:ident< $i$ . $idAcc_of_list is$ >> ];
value rec idApp_of_list =
fun
[ [] -> assert False
| [i] -> i
| [i::is] ->
let _loc = loc_of_ident i in
<:ident< $i$ $idApp_of_list is$ >> ];
value rec mcOr_of_list =
fun
[ [] -> <:match_case@ghost<>>
| [x] -> x
| [x::xs] ->
let _loc = loc_of_match_case x in
<:match_case< $x$ | $mcOr_of_list xs$ >> ];
value rec mbAnd_of_list =
fun
[ [] -> <:module_binding@ghost<>>
| [x] -> x
| [x::xs] ->
let _loc = loc_of_module_binding x in
<:module_binding< $x$ and $mbAnd_of_list xs$ >> ];
value rec meApp_of_list =
fun
[ [] -> assert False
| [x] -> x
| [x::xs] ->
let _loc = loc_of_module_expr x in
<:module_expr< $x$ $meApp_of_list xs$ >> ];
value rec ceAnd_of_list =
fun
[ [] -> <:class_expr@ghost<>>
| [x] -> x
| [x::xs] ->
let _loc = loc_of_class_expr x in
<:class_expr< $x$ and $ceAnd_of_list xs$ >> ];
value rec ctAnd_of_list =
fun
[ [] -> <:class_type@ghost<>>
| [x] -> x
| [x::xs] ->
let _loc = loc_of_class_type x in
<:class_type< $x$ and $ctAnd_of_list xs$ >> ];
value rec cgSem_of_list =
fun
[ [] -> <:class_sig_item@ghost<>>
| [x] -> x
| [x::xs] ->
let _loc = loc_of_class_sig_item x in
<:class_sig_item< $x$; $cgSem_of_list xs$ >> ];
value rec crSem_of_list =
fun
[ [] -> <:class_str_item@ghost<>>
| [x] -> x
| [x::xs] ->
let _loc = loc_of_class_str_item x in
<:class_str_item< $x$; $crSem_of_list xs$ >> ];
value rec paSem_of_list =
fun
[ [] -> <:patt@ghost<>>
| [x] -> x
| [x::xs] ->
let _loc = loc_of_patt x in
<:patt< $x$; $paSem_of_list xs$ >> ];
value rec paCom_of_list =
fun
[ [] -> <:patt@ghost<>>
| [x] -> x
| [x::xs] ->
let _loc = loc_of_patt x in
<:patt< $x$, $paCom_of_list xs$ >> ];
value rec exSem_of_list =
fun
[ [] -> <:expr@ghost<>>
| [x] -> x
| [x::xs] ->
let _loc = loc_of_expr x in
<:expr< $x$; $exSem_of_list xs$ >> ];
value rec exCom_of_list =
fun
[ [] -> <:expr@ghost<>>
| [x] -> x
| [x::xs] ->
let _loc = loc_of_expr x in
<:expr< $x$, $exCom_of_list xs$ >> ];
value ty_of_stl =
fun
[ (_loc, s, []) -> <:ctyp< $uid:s$ >>
| (_loc, s, tl) -> <:ctyp< $uid:s$ of $tyAnd_of_list tl$ >> ];
value ty_of_sbt =
fun
[ (_loc, s, True, t) -> <:ctyp< $lid:s$ : mutable $t$ >>
| (_loc, s, False, t) -> <:ctyp< $lid:s$ : $t$ >> ];
value bi_of_pe (p, e) = let _loc = loc_of_patt p in <:binding< $p$ = $e$ >>;
value sum_type_of_list l = tyOr_of_list (List.map ty_of_stl l);
value record_type_of_list l = tySem_of_list (List.map ty_of_sbt l);
value binding_of_pel l = biAnd_of_list (List.map bi_of_pe l);
value rec pel_of_binding =
fun
[ <:binding< $b1$ and $b2$ >> -> pel_of_binding b1 @ pel_of_binding b2
| <:binding< $p$ = $e$ >> -> [(p, e)]
| _ -> assert False ];
value rec list_of_binding x acc =
match x with
[ <:binding< $b1$ and $b2$ >> ->
list_of_binding b1 (list_of_binding b2 acc)
| t -> [t :: acc] ];
value rec list_of_rec_binding x acc =
match x with
[ <:rec_binding< $b1$; $b2$ >> ->
list_of_rec_binding b1 (list_of_rec_binding b2 acc)
| t -> [t :: acc] ];
value rec list_of_with_constr x acc =
match x with
[ <:with_constr< $w1$ and $w2$ >> ->
list_of_with_constr w1 (list_of_with_constr w2 acc)
| t -> [t :: acc] ];
value rec list_of_ctyp x acc =
match x with
[ <:ctyp<>> -> acc
| <:ctyp< $x$ & $y$ >> | <:ctyp< $x$, $y$ >> |
<:ctyp< $x$ * $y$ >> | <:ctyp< $x$; $y$ >> |
<:ctyp< $x$ and $y$ >> | <:ctyp< $x$ | $y$ >> ->
list_of_ctyp x (list_of_ctyp y acc)
| x -> [x :: acc] ];
value rec list_of_patt x acc =
match x with
[ <:patt<>> -> acc
| <:patt< $x$, $y$ >> | <:patt< $x$; $y$ >> ->
list_of_patt x (list_of_patt y acc)
| x -> [x :: acc] ];
value rec list_of_expr x acc =
match x with
[ <:expr<>> -> acc
| <:expr< $x$, $y$ >> | <:expr< $x$; $y$ >> ->
list_of_expr x (list_of_expr y acc)
| x -> [x :: acc] ];
value rec list_of_str_item x acc =
match x with
[ <:str_item<>> -> acc
| <:str_item< $x$; $y$ >> ->
list_of_str_item x (list_of_str_item y acc)
| x -> [x :: acc] ];
value rec list_of_sig_item x acc =
match x with
[ <:sig_item<>> -> acc
| <:sig_item< $x$; $y$ >> ->
list_of_sig_item x (list_of_sig_item y acc)
| x -> [x :: acc] ];
value rec list_of_class_sig_item x acc =
match x with
[ <:class_sig_item<>> -> acc
| <:class_sig_item< $x$; $y$ >> ->
list_of_class_sig_item x (list_of_class_sig_item y acc)
| x -> [x :: acc] ];
value rec list_of_class_str_item x acc =
match x with
[ <:class_str_item<>> -> acc
| <:class_str_item< $x$; $y$ >> ->
list_of_class_str_item x (list_of_class_str_item y acc)
| x -> [x :: acc] ];
value rec list_of_class_type x acc =
match x with
[ <:class_type< $x$ and $y$ >> ->
list_of_class_type x (list_of_class_type y acc)
| x -> [x :: acc] ];
value rec list_of_class_expr x acc =
match x with
[ <:class_expr< $x$ and $y$ >> ->
list_of_class_expr x (list_of_class_expr y acc)
| x -> [x :: acc] ];
value rec list_of_module_expr x acc =
match x with
[ <:module_expr< $x$ $y$ >> ->
list_of_module_expr x (list_of_module_expr y acc)
| x -> [x :: acc] ];
value rec list_of_match_case x acc =
match x with
[ <:match_case<>> -> acc
| <:match_case< $x$ | $y$ >> ->
list_of_match_case x (list_of_match_case y acc)
| x -> [x :: acc] ];
value rec list_of_ident x acc =
match x with
[ <:ident< $x$ . $y$ >> | <:ident< $x$ $y$ >> ->
list_of_ident x (list_of_ident y acc)
| x -> [x :: acc] ];
value rec list_of_module_binding x acc =
match x with
[ <:module_binding< $x$ and $y$ >> ->
list_of_module_binding x (list_of_module_binding y acc)
| x -> [x :: acc] ];
module Camlp4Trash = struct
INCLUDE "camlp4/Camlp4/Camlp4Ast.partial.ml";
end;
module Meta = struct
module type META_LOC = sig
(** The first location is where to put the returned pattern.
Generally it's _loc to match with <:patt< ... >> quotations.
The second location is the one to treat. *)
value meta_loc_patt : Loc.t -> Loc.t -> Ast.patt;
(** The first location is where to put the returned expression.
Generally it's _loc to match with <:expr< ... >> quotations.
The second location is the one to treat. *)
value meta_loc_expr : Loc.t -> Loc.t -> Ast.expr;
end;
module MetaLoc = struct
value meta_loc_patt _loc location =
let (a, b, c, d, e, f, g, h) = Loc.to_tuple location in
<:patt< Loc.of_tuple
($`str:a$, $`int:b$, $`int:c$, $`int:d$,
$`int:e$, $`int:f$, $`int:g$,
$if h then <:patt< True >> else <:patt< False >> $) >>;
value meta_loc_expr _loc location =
let (a, b, c, d, e, f, g, h) = Loc.to_tuple location in
<:expr< Loc.of_tuple
($`str:a$, $`int:b$, $`int:c$, $`int:d$,
$`int:e$, $`int:f$, $`int:g$,
$if h then <:expr< True >> else <:expr< False >> $) >>;
end;
module MetaGhostLoc = struct
value meta_loc_patt _loc _ = <:patt< Loc.ghost >>;
value meta_loc_expr _loc _ = <:expr< Loc.ghost >>;
end;
module MetaLocVar = struct
value meta_loc_patt _loc _ = <:patt< $lid:Loc.name.val$ >>;
value meta_loc_expr _loc _ = <:expr< $lid:Loc.name.val$ >>;
end;
module Make (MetaLoc : META_LOC) = struct
open MetaLoc;
value meta_loc = meta_loc_expr;
module Expr = Camlp4Filters.MetaGeneratorExpr Ast;
value meta_loc = meta_loc_patt;
module Patt = Camlp4Filters.MetaGeneratorPatt Ast;
end;
end;
class map = Camlp4MapGenerator.generated;
class fold = Camlp4FoldGenerator.generated;
value map_expr f = object
inherit map as super;
method expr x = f (super#expr x);
end;
value map_patt f = object
inherit map as super;
method patt x = f (super#patt x);
end;
value map_ctyp f = object
inherit map as super;
method ctyp x = f (super#ctyp x);
end;
value map_str_item f = object
inherit map as super;
method str_item x = f (super#str_item x);
end;
value map_sig_item f = object
inherit map as super;
method sig_item x = f (super#sig_item x);
end;
value map_loc f = object
inherit map as super;
method loc x = f (super#loc x);
end;
end;

1277
camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml
View File

File diff suppressed because it is too large Load Diff

32
camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.mli
View File

@ -1,32 +0,0 @@
(* camlp4r *)
(****************************************************************************)
(* *)
(* OCaml *)
(* *)
(* INRIA Rocquencourt *)
(* *)
(* Copyright 2002-2006 Institut National de Recherche en Informatique et *)
(* en Automatique. All rights reserved. This file is distributed under *)
(* the terms of the GNU Library General Public License, with the special *)
(* exception on linking described in LICENSE at the top of the OCaml *)
(* source tree. *)
(* *)
(****************************************************************************)
(* Authors:
* - Daniel de Rauglaudre: initial version
* - Nicolas Pouillard: refactoring
*)
module Make (Camlp4Ast : Sig.Camlp4Ast) : sig
open Camlp4Ast;
(** {6 Useful functions} *)
value sig_item : sig_item -> Camlp4_import.Parsetree.signature;
value str_item : str_item -> Camlp4_import.Parsetree.structure;
value phrase : str_item -> Camlp4_import.Parsetree.toplevel_phrase;
end;

145
camlp4/Camlp4/Struct/CleanAst.ml
View File

@ -1,145 +0,0 @@
(****************************************************************************)
(* *)
(* OCaml *)
(* *)
(* INRIA Rocquencourt *)
(* *)
(* Copyright 2006 Institut National de Recherche en Informatique et *)
(* en Automatique. All rights reserved. This file is distributed under *)
(* the terms of the GNU Library General Public License, with the special *)
(* exception on linking described in LICENSE at the top of the OCaml *)
(* source tree. *)
(* *)
(****************************************************************************)
(* Authors:
* - Nicolas Pouillard: initial version
*)
(** This module is suppose to contain nils elimination. *)
module Make (Ast : Sig.Camlp4Ast) = struct
class clean_ast = object
inherit Ast.map as super;
method with_constr wc =
match super#with_constr wc with
[ <:with_constr< $ <:with_constr<>> $ and $wc$ >> |
<:with_constr< $wc$ and $ <:with_constr<>> $ >> -> wc
| wc -> wc ];
method expr e =
match super#expr e with
[ <:expr< let $rec:_$ $ <:binding<>> $ in $e$ >> |
<:expr< { ($e$) with $ <:rec_binding<>> $ } >> |
<:expr< $ <:expr<>> $, $e$ >> |
<:expr< $e$, $ <:expr<>> $ >> |
<:expr< $ <:expr<>> $; $e$ >> |
<:expr< $e$; $ <:expr<>> $ >> -> e
| e -> e ];
method patt p =
match super#patt p with
[ <:patt< ( $p$ as $ <:patt<>> $ ) >> |
<:patt< $ <:patt<>> $ | $p$ >> |
<:patt< $p$ | $ <:patt<>> $ >> |
<:patt< $ <:patt<>> $, $p$ >> |
<:patt< $p$, $ <:patt<>> $ >> |
<:patt< $ <:patt<>> $; $p$ >> |
<:patt< $p$; $ <:patt<>> $ >> -> p
| p -> p ];
method match_case mc =
match super#match_case mc with
[ <:match_case< $ <:match_case<>> $ | $mc$ >> |
<:match_case< $mc$ | $ <:match_case<>> $ >> -> mc
| mc -> mc ];
method binding bi =
match super#binding bi with
[ <:binding< $ <:binding<>> $ and $bi$ >> |
<:binding< $bi$ and $ <:binding<>> $ >> -> bi
| bi -> bi ];
method rec_binding rb =
match super#rec_binding rb with
[ <:rec_binding< $ <:rec_binding<>> $ ; $bi$ >> |
<:rec_binding< $bi$ ; $ <:rec_binding<>> $ >> -> bi
| bi -> bi ];
method module_binding mb =
match super#module_binding mb with
[ <:module_binding< $ <:module_binding<>> $ and $mb$ >> |
<:module_binding< $mb$ and $ <:module_binding<>> $ >> -> mb
| mb -> mb ];
method ctyp t =
match super#ctyp t with
[ <:ctyp< ! $ <:ctyp<>> $ . $t$ >> |
<:ctyp< $ <:ctyp<>> $ as $t$ >> |
<:ctyp< $t$ as $ <:ctyp<>> $ >> |
<:ctyp< $t$ -> $ <:ctyp<>> $ >> |
<:ctyp< $ <:ctyp<>> $ -> $t$ >> |
<:ctyp< $ <:ctyp<>> $ | $t$ >> |
<:ctyp< $t$ | $ <:ctyp<>> $ >> |
<:ctyp< $t$ of $ <:ctyp<>> $ >> |
<:ctyp< $ <:ctyp<>> $ and $t$ >> |
<:ctyp< $t$ and $ <:ctyp<>> $ >> |
<:ctyp< $t$; $ <:ctyp<>> $ >> |
<:ctyp< $ <:ctyp<>> $; $t$ >> |
<:ctyp< $ <:ctyp<>> $, $t$ >> |
<:ctyp< $t$, $ <:ctyp<>> $ >> |
<:ctyp< $t$ & $ <:ctyp<>> $ >> |
<:ctyp< $ <:ctyp<>> $ & $t$ >> |
<:ctyp< $ <:ctyp<>> $ * $t$ >> |
<:ctyp< $t$ * $ <:ctyp<>> $ >> -> t
| t -> t ];
method sig_item sg =
match super#sig_item sg with
[ <:sig_item< $ <:sig_item<>> $; $sg$ >> |
<:sig_item< $sg$; $ <:sig_item<>> $ >> -> sg
| <:sig_item@loc< type $ <:ctyp<>> $ >> -> <:sig_item@loc<>>
| sg -> sg ];
method str_item st =
match super#str_item st with
[ <:str_item< $ <:str_item<>> $; $st$ >> |
<:str_item< $st$; $ <:str_item<>> $ >> -> st
| <:str_item@loc< type $ <:ctyp<>> $ >> -> <:str_item@loc<>>
| <:str_item@loc< value $rec:_$ $ <:binding<>> $ >> -> <:str_item@loc<>>
| st -> st ];
method module_type mt =
match super#module_type mt with
[ <:module_type< $mt$ with $ <:with_constr<>> $ >> -> mt
| mt -> mt ];
method class_expr ce =
match super#class_expr ce with
[ <:class_expr< $ <:class_expr<>> $ and $ce$ >> |
<:class_expr< $ce$ and $ <:class_expr<>> $ >> -> ce
| ce -> ce ];
method class_type ct =
match super#class_type ct with
[ <:class_type< $ <:class_type<>> $ and $ct$ >> |
<:class_type< $ct$ and $ <:class_type<>> $ >> -> ct
| ct -> ct ];
method class_sig_item csg =
match super#class_sig_item csg with
[ <:class_sig_item< $ <:class_sig_item<>> $; $csg$ >> |
<:class_sig_item< $csg$; $ <:class_sig_item<>> $ >> -> csg
| csg -> csg ];
method class_str_item cst =
match super#class_str_item cst with
[ <:class_str_item< $ <:class_str_item<>> $; $cst$ >> |
<:class_str_item< $cst$; $ <:class_str_item<>> $ >> -> cst
| cst -> cst ];
end;
end;

56
camlp4/Camlp4/Struct/CommentFilter.ml
View File

@ -1,56 +0,0 @@
(****************************************************************************)
(* *)
(* OCaml *)
(* *)
(* INRIA Rocquencourt *)
(* *)
(* Copyright 2006 Institut National de Recherche en Informatique et *)
(* en Automatique. All rights reserved. This file is distributed under *)
(* the terms of the GNU Library General Public License, with the special *)
(* exception on linking described in LICENSE at the top of the OCaml *)
(* source tree. *)
(* *)
(****************************************************************************)
(* Authors:
* - Daniel de Rauglaudre: initial version
* - Nicolas Pouillard: refactoring
*)
module Make (Token : Sig.Camlp4Token) = struct
open Token;
type t = (Stream.t (string * Loc.t) * Queue.t (string * Loc.t));
value mk () =
let q = Queue.create () in
let f _ =
debug comments "take...@\n" in
try Some (Queue.take q) with [ Queue.Empty -> None ]
in (Stream.from f, q);
value filter (_, q) =
let rec self =
parser
[ [: ` (Sig.COMMENT x, loc); xs :] ->
do { Queue.add (x, loc) q;
debug comments "add: %S at %a@\n" x Loc.dump loc in
self xs }
| [: ` x; xs :] ->
(* debug comments "Found %a at %a@." Token.print x Loc.dump loc in *)
[: ` x; self xs :]
| [: :] -> [: :] ]
in self;
value take_list (_, q) =
let rec self accu =
if Queue.is_empty q then accu else self [Queue.take q :: accu]
in self [];
value take_stream = fst;
value define token_fiter comments_strm =
debug comments "Define a comment filter@\n" in
Token.Filter.define_filter token_fiter
(fun previous strm -> previous (filter comments_strm strm));
end;

33
camlp4/Camlp4/Struct/CommentFilter.mli
View File

@ -1,33 +0,0 @@
(****************************************************************************)
(* *)
(* OCaml *)
(* *)
(* INRIA Rocquencourt *)
(* *)
(* Copyright 2006 Institut National de Recherche en Informatique et *)
(* en Automatique. All rights reserved. This file is distributed under *)
(* the terms of the GNU Library General Public License, with the special *)
(* exception on linking described in LICENSE at the top of the OCaml *)
(* source tree. *)
(* *)
(****************************************************************************)
(* Authors:
* - Daniel de Rauglaudre: initial version
* - Nicolas Pouillard: refactoring
*)
module Make (Token : Sig.Camlp4Token) : sig
open Token;
type t;
value mk : unit -> t;
value define : Token.Filter.t -> t -> unit;
value filter : t -> Stream.t (Token.t * Loc.t) -> Stream.t (Token.t * Loc.t);
value take_list : t -> list (string * Loc.t);
value take_stream : t -> Stream.t (string * Loc.t);
end;

91
camlp4/Camlp4/Struct/DynAst.ml
View File

@ -1,91 +0,0 @@
(* camlp4r *)
(****************************************************************************)
(* *)
(* OCaml *)
(* *)
(* INRIA Rocquencourt *)
(* *)
(* Copyright 2007 Institut National de Recherche en Informatique et *)
(* en Automatique. All rights reserved. This file is distributed under *)
(* the terms of the GNU Library General Public License, with the special *)
(* exception on linking described in LICENSE at the top of the OCaml *)
(* source tree. *)
(* *)
(****************************************************************************)
(* Authors:
* - Nicolas Pouillard: initial version
*)
module Make (Ast : Sig.Ast) : Sig.DynAst with module Ast = Ast = struct
module Ast = Ast;
type tag 'a =
[ Tag_ctyp
| Tag_patt
| Tag_expr
| Tag_module_type
| Tag_sig_item
| Tag_with_constr
| Tag_module_expr
| Tag_str_item
| Tag_class_type
| Tag_class_sig_item
| Tag_class_expr
| Tag_class_str_item
| Tag_match_case
| Tag_ident
| Tag_binding
| Tag_rec_binding
| Tag_module_binding ];
value string_of_tag =
fun
[ Tag_ctyp -> "ctyp"
| Tag_patt -> "patt"
| Tag_expr -> "expr"
| Tag_module_type -> "module_type"
| Tag_sig_item -> "sig_item"
| Tag_with_constr -> "with_constr"
| Tag_module_expr -> "module_expr"
| Tag_str_item -> "str_item"
| Tag_class_type -> "class_type"
| Tag_class_sig_item -> "class_sig_item"
| Tag_class_expr -> "class_expr"
| Tag_class_str_item -> "class_str_item"
| Tag_match_case -> "match_case"
| Tag_ident -> "ident"
| Tag_binding -> "binding"
| Tag_rec_binding -> "rec_binding"
| Tag_module_binding -> "module_binding" ];
value ctyp_tag = Tag_ctyp;
value patt_tag = Tag_patt;
value expr_tag = Tag_expr;
value module_type_tag = Tag_module_type;
value sig_item_tag = Tag_sig_item;
value with_constr_tag = Tag_with_constr;
value module_expr_tag = Tag_module_expr;
value str_item_tag = Tag_str_item;
value class_type_tag = Tag_class_type;
value class_sig_item_tag = Tag_class_sig_item;
value class_expr_tag = Tag_class_expr;
value class_str_item_tag = Tag_class_str_item;
value match_case_tag = Tag_match_case;
value ident_tag = Tag_ident;
value binding_tag = Tag_binding;
value rec_binding_tag = Tag_rec_binding;
value module_binding_tag = Tag_module_binding;
type dyn;
external dyn_tag : tag 'a -> tag dyn = "%identity";
module Pack(X : sig type t 'a; end) = struct
(* These Obj.* hacks should be avoided with GADTs *)
type pack = (tag dyn * Obj.t);
exception Pack_error;
value pack tag v = (dyn_tag tag, Obj.repr v);
value unpack (tag : tag 'a) (tag', obj) =
if dyn_tag tag = tag' then (Obj.obj obj : X.t 'a) else raise Pack_error;
value print_tag f (tag, _) = Format.pp_print_string f (string_of_tag tag);
end;
end;

84
camlp4/Camlp4/Struct/DynLoader.ml
View File

@ -1,84 +0,0 @@
(* camlp4r pa_macro.cmo *)
(****************************************************************************)
(* *)
(* OCaml *)
(* *)
(* INRIA Rocquencourt *)
(* *)
(* Copyright 2001-2006 Institut National de Recherche en Informatique et *)
(* en Automatique. All rights reserved. This file is distributed under *)
(* the terms of the GNU Library General Public License, with the special *)
(* exception on linking described in LICENSE at the top of the OCaml *)
(* source tree. *)
(* *)
(****************************************************************************)
(* Authors:
* - Daniel de Rauglaudre: initial version
* - Nicolas Pouillard: refactoring
*)
type t = Queue.t string;
exception Error of string and string;
value include_dir x y = Queue.add y x;
value fold_load_path x f acc = Queue.fold (fun x y -> f y x) acc x;
value mk ?(ocaml_stdlib = True) ?(camlp4_stdlib = True) () =
let q = Queue.create () in do {
if ocaml_stdlib then include_dir q Camlp4_config.ocaml_standard_library else ();
if camlp4_stdlib then do {
include_dir q Camlp4_config.camlp4_standard_library;
include_dir q (Filename.concat Camlp4_config.camlp4_standard_library "Camlp4Parsers");
include_dir q (Filename.concat Camlp4_config.camlp4_standard_library "Camlp4Printers");
include_dir q (Filename.concat Camlp4_config.camlp4_standard_library "Camlp4Filters");
} else ();
include_dir q ".";
q
};
(* Load files in core *)
value find_in_path x name =
if not (Filename.is_implicit name) then
if Sys.file_exists name then name else raise Not_found
else
let res =
fold_load_path x
(fun dir ->
fun
[ None ->
let fullname = Filename.concat dir name in
if Sys.file_exists fullname then Some fullname else None
| x -> x ]) None
in match res with [ None -> raise Not_found | Some x -> x ];
value load =
let _initialized = ref False in
fun _path file ->
do {
if not _initialized.val then
try do {
Dynlink.init ();
Dynlink.allow_unsafe_modules True;
_initialized.val := True
}
with
[ Dynlink.Error e ->
raise (Error "Camlp4's dynamic loader initialization" (Dynlink.error_message e)) ]
else ();
let fname =
try find_in_path _path file with
[ Not_found -> raise (Error file "file not found in path") ]
in
try Dynlink.loadfile fname with
[ Dynlink.Error e -> raise (Error fname (Dynlink.error_message e)) ]
};
value is_native = Dynlink.is_native;

20
camlp4/Camlp4/Struct/DynLoader.mli
View File

@ -1,20 +0,0 @@
(****************************************************************************)
(* *)
(* OCaml *)
(* *)
(* INRIA Rocquencourt *)
(* *)
(* Copyright 2006 Institut National de Recherche en Informatique et *)
(* en Automatique. All rights reserved. This file is distributed under *)
(* the terms of the GNU Library General Public License, with the special *)
(* exception on linking described in LICENSE at the top of the OCaml *)
(* source tree. *)
(* *)
(****************************************************************************)
(* Authors:
* - Daniel de Rauglaudre: initial version
* - Nicolas Pouillard: refactoring
*)
include Sig.DynLoader;

22
camlp4/Camlp4/Struct/EmptyError.ml
View File

@ -1,22 +0,0 @@
(****************************************************************************)
(* *)
(* OCaml *)
(* *)
(* INRIA Rocquencourt *)
(* *)
(* Copyright 2006 Institut National de Recherche en Informatique et *)
(* en Automatique. All rights reserved. This file is distributed under *)
(* the terms of the GNU Library General Public License, with the special *)
(* exception on linking described in LICENSE at the top of the OCaml *)
(* source tree. *)
(* *)
(****************************************************************************)
(* Authors:
* - Daniel de Rauglaudre: initial version
* - Nicolas Pouillard: refactoring
*)
type t = unit;
exception E of t;
value print _ = assert False;
value to_string _ = assert False;

19
camlp4/Camlp4/Struct/EmptyError.mli
View File

@ -1,19 +0,0 @@
(****************************************************************************)
(* *)
(* OCaml *)
(* *)
(* INRIA Rocquencourt *)
(* *)
(* Copyright 2006 Institut National de Recherche en Informatique et *)
(* en Automatique. All rights reserved. This file is distributed under *)
(* the terms of the GNU Library General Public License, with the special *)
(* exception on linking described in LICENSE at the top of the OCaml *)
(* source tree. *)
(* *)
(****************************************************************************)
(* Authors:
* - Daniel de Rauglaudre: initial version
* - Nicolas Pouillard: refactoring
*)
include Sig.Error;

22
camlp4/Camlp4/Struct/EmptyPrinter.ml
View File

@ -1,22 +0,0 @@
(****************************************************************************)
(* *)
(* OCaml *)
(* *)
(* INRIA Rocquencourt *)
(* *)
(* Copyright 2006 Institut National de Recherche en Informatique et *)
(* en Automatique. All rights reserved. This file is distributed under *)
(* the terms of the GNU Library General Public License, with the special *)
(* exception on linking described in LICENSE at the top of the OCaml *)
(* source tree. *)
(* *)
(****************************************************************************)
(* Authors:
* - Nicolas Pouillard: initial version
*)
module Make (Ast : Sig.Ast) = struct
value print_interf ?input_file:(_) ?output_file:(_) _ = failwith "No interface printer";
value print_implem ?input_file:(_) ?output_file:(_) _ = failwith "No implementation printer";
end;

19
camlp4/Camlp4/Struct/EmptyPrinter.mli
View File

@ -1,19 +0,0 @@
(****************************************************************************)
(* *)
(* OCaml *)
(* *)
(* INRIA Rocquencourt *)
(* *)
(* Copyright 2006-2006 Institut National de Recherche en Informatique et *)
(* en Automatique. All rights reserved. This file is distributed under *)
(* the terms of the GNU Library General Public License, with the special *)
(* exception on linking described in LICENSE at the top of the OCaml *)
(* source tree. *)
(* *)
(****************************************************************************)
(* Authors:
* - Nicolas Pouillard: initial version
*)
module Make (Ast : Sig.Ast) : (Sig.Printer Ast).S;

127
camlp4/Camlp4/Struct/FreeVars.ml
View File

@ -1,127 +0,0 @@
(* camlp4r *)
(****************************************************************************)
(* *)
(* OCaml *)
(* *)
(* INRIA Rocquencourt *)
(* *)
(* Copyright 2006 Institut National de Recherche en Informatique et *)
(* en Automatique. All rights reserved. This file is distributed under *)
(* the terms of the GNU Library General Public License, with the special *)
(* exception on linking described in LICENSE at the top of the OCaml *)
(* source tree. *)
(* *)
(****************************************************************************)
(* Authors:
* - Nicolas Pouillard: initial version
*)
module Make (Ast : Sig.Camlp4Ast) = struct
module S = Set.Make String;
class c_fold_pattern_vars ['accu] f init =
object
inherit Ast.fold as super;
value acc = init;
method acc : 'accu = acc;
method patt =
fun
[ <:patt< $lid:s$ >> | <:patt< ~ $s$ >> | <:patt< ? $s$ >> ->
{< acc = f s acc >}
| p -> super#patt p ];
end;
value fold_pattern_vars f p init = ((new c_fold_pattern_vars f init)#patt p)#acc;
value rec fold_binding_vars f bi acc =
match bi with
[ <:binding< $bi1$ and $bi2$ >> ->
fold_binding_vars f bi1 (fold_binding_vars f bi2 acc)
| <:binding< $p$ = $_$ >> -> fold_pattern_vars f p acc
| <:binding<>> -> acc
| <:binding< $anti:_$ >> -> assert False ];
class fold_free_vars ['accu] (f : string -> 'accu -> 'accu) ?(env_init = S.empty) free_init =
object (o)
inherit Ast.fold as super;
value free : 'accu = free_init;
value env : S.t = env_init;
method free = free;
method set_env env = {< env = env >};
method add_atom s = {< env = S.add s env >};
method add_patt p = {< env = fold_pattern_vars S.add p env >};
method add_binding bi = {< env = fold_binding_vars S.add bi env >};
method expr =
fun
[ <:expr< $lid:s$ >> | <:expr< ~ $s$ >> | <:expr< ? $s$ >> ->
if S.mem s env then o else {< free = f s free >}
| <:expr< let $bi$ in $e$ >> ->
(((o#add_binding bi)#expr e)#set_env env)#binding bi
| <:expr< let rec $bi$ in $e$ >> ->
(((o#add_binding bi)#expr e)#binding bi)#set_env env
| <:expr< for $s$ = $e1$ $to:_$ $e2$ do { $e3$ } >> ->
((((o#expr e1)#expr e2)#add_atom s)#expr e3)#set_env env
| <:expr< $id:_$ >> | <:expr< new $_$ >> -> o
| <:expr< object ($p$) $cst$ end >> ->
((o#add_patt p)#class_str_item cst)#set_env env
| e -> super#expr e ];
method match_case =
fun
[ <:match_case< $p$ when $e1$ -> $e2$ >> ->
(((o#add_patt p)#expr e1)#expr e2)#set_env env
| m -> super#match_case m ];
method str_item =
fun
[ <:str_item< external $s$ : $t$ = $_$ >> ->
(o#ctyp t)#add_atom s
| <:str_item< value $bi$ >> ->
(o#binding bi)#add_binding bi
| <:str_item< value rec $bi$ >> ->
(o#add_binding bi)#binding bi
| st -> super#str_item st ];
method class_expr =
fun
[ <:class_expr< fun $p$ -> $ce$ >> ->
((o#add_patt p)#class_expr ce)#set_env env
| <:class_expr< let $bi$ in $ce$ >> ->
(((o#binding bi)#add_binding bi)#class_expr ce)#set_env env
| <:class_expr< let rec $bi$ in $ce$ >> ->
(((o#add_binding bi)#binding bi)#class_expr ce)#set_env env
| <:class_expr< object ($p$) $cst$ end >> ->
((o#add_patt p)#class_str_item cst)#set_env env
| ce -> super#class_expr ce ];
method class_str_item =
fun
[ <:class_str_item< inherit $override:_$ $_$ >> as cst -> super#class_str_item cst
| <:class_str_item< inherit $override:_$ $ce$ as $s$ >> ->
(o#class_expr ce)#add_atom s
| <:class_str_item< value $override:_$ $mutable:_$ $s$ = $e$ >> ->
(o#expr e)#add_atom s
| <:class_str_item< value virtual $mutable:_$ $s$ : $t$ >> ->
(o#ctyp t)#add_atom s
| cst -> super#class_str_item cst ];
method module_expr = fun
[ <:module_expr< struct $st$ end >> ->
(o#str_item st)#set_env env
| me -> super#module_expr me ];
end;
value free_vars env_init e =
let fold = new fold_free_vars S.add ~env_init S.empty in (fold#expr e)#free;
end;

48
camlp4/Camlp4/Struct/FreeVars.mli
View File

@ -1,48 +0,0 @@
(* camlp4r *)
(****************************************************************************)
(* *)
(* OCaml *)
(* *)
(* INRIA Rocquencourt *)
(* *)
(* Copyright 2006 Institut National de Recherche en Informatique et *)
(* en Automatique. All rights reserved. This file is distributed under *)
(* the terms of the GNU Library General Public License, with the special *)
(* exception on linking described in LICENSE at the top of the OCaml *)
(* source tree. *)
(* *)
(****************************************************************************)
(* Authors:
* - Nicolas Pouillard: initial version
*)
module Make (Ast : Sig.Camlp4Ast) : sig
module S : Set.S with type elt = string;
value fold_binding_vars : (string -> 'accu -> 'accu) -> Ast.binding -> 'accu -> 'accu;
class c_fold_pattern_vars ['accu] : [string -> 'accu -> 'accu] -> ['accu] ->
object
inherit Ast.fold;
value acc : 'accu;
method acc : 'accu;
end;
value fold_pattern_vars : (string -> 'accu -> 'accu) -> Ast.patt -> 'accu -> 'accu;
class fold_free_vars ['accu] : [string -> 'accu -> 'accu] -> [?env_init:S.t] -> ['accu] ->
object ('self_type)
inherit Ast.fold;
value free : 'accu;
value env : S.t;
method free : 'accu;
method set_env : S.t -> 'self_type;
method add_atom : string -> 'self_type;
method add_patt : Ast.patt -> 'self_type;
method add_binding : Ast.binding -> 'self_type;
end;
value free_vars : S.t -> Ast.expr -> S.t;
end;

13
camlp4/Camlp4/Struct/Grammar.mlpack
View File

@ -1,13 +0,0 @@
Delete
Dynamic
Entry
Failed
Find
Fold
Insert
Parser
Print
Search
Static
Structure
Tools

187
camlp4/Camlp4/Struct/Grammar/Delete.ml
View File

@ -1,187 +0,0 @@
(****************************************************************************)
(* *)
(* OCaml *)
(* *)
(* INRIA Rocquencourt *)
(* *)
(* Copyright 2006 Institut National de Recherche en Informatique et *)
(* en Automatique. All rights reserved. This file is distributed under *)
(* the terms of the GNU Library General Public License, with the special *)
(* exception on linking described in LICENSE at the top of the OCaml *)
(* source tree. *)
(* *)
(****************************************************************************)
(* Authors:
* - Daniel de Rauglaudre: initial version
* - Nicolas Pouillard: refactoring
*)
exception Rule_not_found of (string * string);
let () =
Printexc.register_printer
(fun
[ Rule_not_found (symbols, entry) ->
let msg = Printf.sprintf "rule %S cannot be found in entry\n%s" symbols entry in
Some msg
| _ -> None ]) in ()
;
module Make (Structure : Structure.S) = struct
module Tools = Tools.Make Structure;
module Parser = Parser.Make Structure;
module Print = Print.Make Structure;
open Structure;
value raise_rule_not_found entry symbols =
let to_string f x =
let buff = Buffer.create 128 in
let ppf = Format.formatter_of_buffer buff in
do {
f ppf x;
Format.pp_print_flush ppf ();
Buffer.contents buff
} in
let entry = to_string Print.entry entry in
let symbols = to_string Print.print_rule symbols in
raise (Rule_not_found (symbols, entry))
;
(* Deleting a rule *)
(* [delete_rule_in_tree] returns
[Some (dsl, t)] if success
[dsl] =
Some (list of deleted nodes) if branch deleted
None if action replaced by previous version of action
[t] = remaining tree
[None] if failure *)
value delete_rule_in_tree entry =
let rec delete_in_tree symbols tree =
match (symbols, tree) with
[ ([s :: sl], Node n) ->
if Tools.logically_eq_symbols entry s n.node then delete_son sl n
else
match delete_in_tree symbols n.brother with
[ Some (dsl, t) ->
Some (dsl, Node {node = n.node; son = n.son; brother = t})
| None -> None ]
| ([_ :: _], _) -> None
| ([], Node n) ->
match delete_in_tree [] n.brother with
[ Some (dsl, t) ->
Some (dsl, Node {node = n.node; son = n.son; brother = t})
| None -> None ]
| ([], DeadEnd) -> None
| ([], LocAct _ []) -> Some (Some [], DeadEnd)
| ([], LocAct _ [action :: list]) -> Some (None, LocAct action list) ]
and delete_son sl n =
match delete_in_tree sl n.son with
[ Some (Some dsl, DeadEnd) -> Some (Some [n.node :: dsl], n.brother)
| Some (Some dsl, t) ->
let t = Node {node = n.node; son = t; brother = n.brother} in
Some (Some [n.node :: dsl], t)
| Some (None, t) ->
let t = Node {node = n.node; son = t; brother = n.brother} in
Some (None, t)
| None -> None ]
in
delete_in_tree
;
value rec decr_keyw_use gram =
fun
[ Skeyword kwd -> removing gram kwd
| Smeta _ sl _ -> List.iter (decr_keyw_use gram) sl
| Slist0 s | Slist1 s | Sopt s | Stry s -> decr_keyw_use gram s
| Slist0sep s1 s2 -> do { decr_keyw_use gram s1; decr_keyw_use gram s2 }
| Slist1sep s1 s2 -> do { decr_keyw_use gram s1; decr_keyw_use gram s2 }
| Stree t -> decr_keyw_use_in_tree gram t
| Sself | Snext | Snterm _ | Snterml _ _ | Stoken _ -> () ]
and decr_keyw_use_in_tree gram =
fun
[ DeadEnd | LocAct _ _ -> ()
| Node n ->
do {
decr_keyw_use gram n.node;
decr_keyw_use_in_tree gram n.son;
decr_keyw_use_in_tree gram n.brother
} ]
;
value rec delete_rule_in_suffix entry symbols =
fun
[ [lev :: levs] ->
match delete_rule_in_tree entry symbols lev.lsuffix with
[ Some (dsl, t) ->
do {
match dsl with
[ Some dsl -> List.iter (decr_keyw_use entry.egram) dsl
| None -> () ];
match t with
[ DeadEnd when lev.lprefix == DeadEnd -> levs
| _ ->
let lev =
{assoc = lev.assoc; lname = lev.lname; lsuffix = t;
lprefix = lev.lprefix}
in
[lev :: levs] ]
}
| None ->
let levs = delete_rule_in_suffix entry symbols levs in
[lev :: levs] ]
| [] -> raise_rule_not_found entry symbols ]
;
value rec delete_rule_in_prefix entry symbols =
fun
[ [lev :: levs] ->
match delete_rule_in_tree entry symbols lev.lprefix with
[ Some (dsl, t) ->
do {
match dsl with
[ Some dsl -> List.iter (decr_keyw_use entry.egram) dsl
| None -> () ];
match t with
[ DeadEnd when lev.lsuffix == DeadEnd -> levs
| _ ->
let lev =
{assoc = lev.assoc; lname = lev.lname;
lsuffix = lev.lsuffix; lprefix = t}
in
[lev :: levs] ]
}
| None ->
let levs = delete_rule_in_prefix entry symbols levs in
[lev :: levs] ]
| [] -> raise_rule_not_found entry symbols ]
;
value rec delete_rule_in_level_list entry symbols levs =
match symbols with
[ [Sself :: symbols] -> delete_rule_in_suffix entry symbols levs
| [Snterm e :: symbols] when e == entry ->
delete_rule_in_suffix entry symbols levs
| _ -> delete_rule_in_prefix entry symbols levs ]
;
value delete_rule entry sl =
match entry.edesc with
[ Dlevels levs ->
let levs = delete_rule_in_level_list entry sl levs in
do {
entry.edesc := Dlevels levs;
entry.estart :=
fun lev strm ->
let f = Parser.start_parser_of_entry entry in
do { entry.estart := f; f lev strm };
entry.econtinue :=
fun lev bp a strm ->
let f = Parser.continue_parser_of_entry entry in
do { entry.econtinue := f; f lev bp a strm }
}
| Dparser _ -> () ]
;
end;

73
camlp4/Camlp4/Struct/Grammar/Dynamic.ml
View File

@ -1,73 +0,0 @@
(****************************************************************************)
(* *)
(* OCaml *)
(* *)
(* INRIA Rocquencourt *)
(* *)
(* Copyright 2006 Institut National de Recherche en Informatique et *)
(* en Automatique. All rights reserved. This file is distributed under *)
(* the terms of the GNU Library General Public License, with the special *)
(* exception on linking described in LICENSE at the top of the OCaml *)
(* source tree. *)
(* *)
(****************************************************************************)
(* Authors:
* - Daniel de Rauglaudre: initial version
* - Nicolas Pouillard: refactoring
*)
module Make (Lexer : Sig.Lexer)
: Sig.Grammar.Dynamic with module Loc = Lexer.Loc
and module Token = Lexer.Token
= struct
module Structure = Structure.Make Lexer;
module Delete = Delete.Make Structure;
module Insert = Insert.Make Structure;
module Entry = Entry.Make Structure;
module Fold = Fold.Make Structure;
module Tools = Tools.Make Structure;
include Structure;
value mk () =
let gkeywords = Hashtbl.create 301 in
{
gkeywords = gkeywords;
gfilter = Token.Filter.mk (Hashtbl.mem gkeywords);
glexer = Lexer.mk ();
warning_verbose = ref True; (* FIXME *)
error_verbose = Camlp4_config.verbose
};
value get_filter g = g.gfilter;
value lex g loc cs = g.glexer loc cs;
value lex_string g loc str = lex g loc (Stream.of_string str);
value filter g ts = Tools.keep_prev_loc (Token.Filter.filter g.gfilter ts);
value parse_tokens_after_filter entry ts = Entry.parse_tokens_after_filter entry ts;
value parse_tokens_before_filter entry ts = parse_tokens_after_filter entry (filter entry.egram ts);
value parse entry loc cs = parse_tokens_before_filter entry (lex entry.egram loc cs);
value parse_string entry loc str =
parse_tokens_before_filter entry (lex_string entry.egram loc str);
value delete_rule = Delete.delete_rule;
value srules e rl =
let t =
List.fold_left
(fun tree (symbols, action) -> Insert.insert_tree e symbols action tree)
DeadEnd rl
in
Stree t;
value sfold0 = Fold.sfold0;
value sfold1 = Fold.sfold1;
value sfold0sep = Fold.sfold0sep;
(* value sfold1sep = Fold.sfold1sep; *)
value extend = Insert.extend;
end;

92
camlp4/Camlp4/Struct/Grammar/Entry.ml
View File

@ -1,92 +0,0 @@
(****************************************************************************)
(* *)
(* OCaml *)
(* *)
(* INRIA Rocquencourt *)
(* *)
(* Copyright 2006 Institut National de Recherche en Informatique et *)
(* en Automatique. All rights reserved. This file is distributed under *)
(* the terms of the GNU Library General Public License, with the special *)
(* exception on linking described in LICENSE at the top of the OCaml *)
(* source tree. *)
(* *)
(****************************************************************************)
(* Authors:
* - Daniel de Rauglaudre: initial version
* - Nicolas Pouillard: refactoring
*)
module Make (Structure : Structure.S) = struct
module Dump = Print.MakeDump Structure;
module Print = Print.Make Structure;
module Tools = Tools.Make Structure;
open Format;
open Structure;
open Tools;
type t 'a = internal_entry;
value name e = e.ename;
value print ppf e = fprintf ppf "%a@\n" Print.entry e;
value dump ppf e = fprintf ppf "%a@\n" Dump.entry e;
(* value find e s = Find.entry e s; *)
value mk g n =
{ egram = g;
ename = n;
estart = empty_entry n;
econtinue _ _ _ = parser [];
edesc = Dlevels [] };
value action_parse entry ts : Action.t =
try entry.estart 0 ts with
[ Stream.Failure ->
Loc.raise (get_prev_loc ts)
(Stream.Error ("illegal begin of " ^ entry.ename))
| Loc.Exc_located _ _ as exc -> raise exc
| exc -> Loc.raise (get_prev_loc ts) exc ];
value lex entry loc cs = entry.egram.glexer loc cs;
value lex_string entry loc str = lex entry loc (Stream.of_string str);
value filter entry ts =
keep_prev_loc (Token.Filter.filter (get_filter entry.egram) ts);
value parse_tokens_after_filter entry ts = Action.get (action_parse entry ts);
value parse_tokens_before_filter entry ts = parse_tokens_after_filter entry (filter entry ts);
value parse entry loc cs = parse_tokens_before_filter entry (lex entry loc cs);
value parse_string entry loc str =
parse_tokens_before_filter entry (lex_string entry loc str);
value of_parser g n (p : Stream.t (Token.t * token_info) -> 'a) : t 'a =
let f ts = Action.mk (p ts) in
{ egram = g;
ename = n;
estart _ = f;
econtinue _ _ _ = parser [];
edesc = Dparser f };
value setup_parser e (p : Stream.t (Token.t * token_info) -> 'a) =
let f ts = Action.mk (p ts) in do {
e.estart := fun _ -> f;
e.econtinue := fun _ _ _ -> parser [];
e.edesc := Dparser f
};
value clear e =
do {
e.estart := fun _ -> parser [];
e.econtinue := fun _ _ _ -> parser [];
e.edesc := Dlevels []
};
value obj x = x;
end;

132
camlp4/Camlp4/Struct/Grammar/Failed.ml
View File

@ -1,132 +0,0 @@
(****************************************************************************)
(* *)
(* OCaml *)
(* *)
(* INRIA Rocquencourt *)
(* *)
(* Copyright 2006 Institut National de Recherche en Informatique et *)
(* en Automatique. All rights reserved. This file is distributed under *)
(* the terms of the GNU Library General Public License, with the special *)
(* exception on linking described in LICENSE at the top of the OCaml *)
(* source tree. *)
(* *)
(****************************************************************************)
(* Authors:
* - Daniel de Rauglaudre: initial version
* - Nicolas Pouillard: refactoring
*)
module Make (Structure : Structure.S) = struct
module Tools = Tools.Make Structure;
module Search = Search.Make Structure;
module Print = Print.Make Structure;
open Structure;
open Format;
value rec name_of_symbol entry =
fun
[ Snterm e -> "[" ^ e.ename ^ "]"
| Snterml e l -> "[" ^ e.ename ^ " level " ^ l ^ "]"
| Sself | Snext -> "[" ^ entry.ename ^ "]"
| Stoken (_, descr) -> descr
| Skeyword kwd -> "\"" ^ kwd ^ "\""
| _ -> "???" ]
;
value rec name_of_symbol_failed entry =
fun
[ Slist0 s | Slist0sep s _ |
Slist1 s | Slist1sep s _ |
Sopt s | Stry s -> name_of_symbol_failed entry s
| Stree t -> name_of_tree_failed entry t
| s -> name_of_symbol entry s ]
and name_of_tree_failed entry =
fun
[ Node {node = s; brother = bro; son = son} ->
let tokl =
match s with
[ Stoken _ | Skeyword _ -> Tools.get_token_list entry [] s son
| _ -> None ]
in
match tokl with
[ None ->
let txt = name_of_symbol_failed entry s in
let txt =
match (s, son) with
[ (Sopt _, Node _) -> txt ^ " or " ^ name_of_tree_failed entry son
| _ -> txt ]
in
let txt =
match bro with
[ DeadEnd | LocAct _ _ -> txt
| Node _ -> txt ^ " or " ^ name_of_tree_failed entry bro ]
in
txt
| Some (tokl, _, _) ->
List.fold_left
(fun s tok ->
(if s = "" then "" else s ^ " then ") ^
match tok with
[ Stoken (_, descr) -> descr
| Skeyword kwd -> kwd
| _ -> assert False ])
"" tokl ]
| DeadEnd | LocAct _ _ -> "???" ]
;
value magic _s x = debug magic "Obj.magic: %s@." _s in Obj.magic x;
value tree_failed entry prev_symb_result prev_symb tree =
let txt = name_of_tree_failed entry tree in
let txt =
match prev_symb with
[ Slist0 s ->
let txt1 = name_of_symbol_failed entry s in
txt1 ^ " or " ^ txt ^ " expected"
| Slist1 s ->
let txt1 = name_of_symbol_failed entry s in
txt1 ^ " or " ^ txt ^ " expected"
| Slist0sep s sep ->
match magic "tree_failed: 'a -> list 'b" prev_symb_result with
[ [] ->
let txt1 = name_of_symbol_failed entry s in
txt1 ^ " or " ^ txt ^ " expected"
| _ ->
let txt1 = name_of_symbol_failed entry sep in
txt1 ^ " or " ^ txt ^ " expected" ]
| Slist1sep s sep ->
match magic "tree_failed: 'a -> list 'b" prev_symb_result with
[ [] ->
let txt1 = name_of_symbol_failed entry s in
txt1 ^ " or " ^ txt ^ " expected"
| _ ->
let txt1 = name_of_symbol_failed entry sep in
txt1 ^ " or " ^ txt ^ " expected" ]
| Stry _(*NP: not sure about this*) | Sopt _ | Stree _ -> txt ^ " expected"
| _ -> txt ^ " expected after " ^ name_of_symbol entry prev_symb ]
in
do {
if entry.egram.error_verbose.val then do {
let tree = Search.tree_in_entry prev_symb tree entry.edesc;
let ppf = err_formatter;
fprintf ppf "@[<v 0>@,";
fprintf ppf "----------------------------------@,";
fprintf ppf "Parse error in entry [%s], rule:@;<0 2>" entry.ename;
fprintf ppf "@[";
Print.print_level ppf pp_force_newline (Print.flatten_tree tree);
fprintf ppf "@]@,";
fprintf ppf "----------------------------------@,";
fprintf ppf "@]@."
}
else ();
txt ^ " (in [" ^ entry.ename ^ "])"
}
;
value symb_failed entry prev_symb_result prev_symb symb =
let tree = Node {node = symb; brother = DeadEnd; son = DeadEnd} in
tree_failed entry prev_symb_result prev_symb tree
;
value symb_failed_txt e s1 s2 = symb_failed e 0 s1 s2;
end;

68
camlp4/Camlp4/Struct/Grammar/Find.ml
View File

@ -1,68 +0,0 @@
(****************************************************************************)
(* *)
(* OCaml *)
(* *)
(* INRIA Rocquencourt *)
(* *)
(* Copyright 2006 Institut National de Recherche en Informatique et *)
(* en Automatique. All rights reserved. This file is distributed under *)
(* the terms of the GNU Library General Public License, with the special *)
(* exception on linking described in LICENSE at the top of the OCaml *)
(* source tree. *)
(* *)
(****************************************************************************)
(* Authors:
* - Daniel de Rauglaudre: initial version
* - Nicolas Pouillard: refactoring
*)
(*
value entry e s =
let rec find_levels =
fun
[ [] -> None
| [lev :: levs] ->
match find_tree lev.lsuffix with
[ None ->
match find_tree lev.lprefix with
[ None -> find_levels levs
| x -> x ]
| x -> x ] ]
and symbol =
fun
[ Snterm e -> if e.ename = s then Some e else None
| Snterml e _ -> if e.ename = s then Some e else None
| Smeta _ sl _ -> find_symbol_list sl
| Slist0 s -> find_symbol s
| Slist0sep s _ -> find_symbol s
| Slist1 s -> find_symbol s
| Slist1sep s _ -> find_symbol s
| Sopt s -> find_symbol s
| Stree t -> find_tree t
| Sself | Snext | Stoken _ | Stoken_fun _ -> None ]
and symbol_list =
fun
[ [s :: sl] ->
match find_symbol s with
[ None -> find_symbol_list sl
| x -> x ]
| [] -> None ]
and tree =
fun
[ Node {node = s; brother = bro; son = son} ->
match find_symbol s with
[ None ->
match find_tree bro with
[ None -> find_tree son
| x -> x ]
| x -> x ]
| LocAct _ _ | DeadEnd -> None ]
in
match e.edesc with
[ Dlevels levs ->
match find_levels levs with
[ Some e -> e
| None -> raise Not_found ]
| Dparser _ -> raise Not_found ]
;
*)

95
camlp4/Camlp4/Struct/Grammar/Fold.ml
View File

@ -1,95 +0,0 @@
(* camlp4r *)
(****************************************************************************)
(* *)
(* OCaml *)
(* *)
(* INRIA Rocquencourt *)
(* *)
(* Copyright 2006 Institut National de Recherche en Informatique et *)
(* en Automatique. All rights reserved. This file is distributed under *)
(* the terms of the GNU Library General Public License, with the special *)
(* exception on linking described in LICENSE at the top of the OCaml *)
(* source tree. *)
(* *)
(****************************************************************************)
(* Authors:
* - Daniel de Rauglaudre: initial version
* - Nicolas Pouillard: refactoring
*)
module Make (Structure : Structure.S) = struct
open Structure;
open Format;
module Parse = Parser.Make Structure;
module Fail = Failed.Make Structure;
open Sig.Grammar;
(* Prevent from implict usage. *)
module Stream = struct
type t 'a = Stream.t 'a;
exception Failure = Stream.Failure;
exception Error = Stream.Error;
end;
value sfold0 f e _entry _symbl psymb =
let rec fold accu =
parser
[ [: a = psymb; s :] -> fold (f a accu) s
| [: :] -> accu ]
in
parser [: a = fold e :] -> a
;
value sfold1 f e _entry _symbl psymb =
let rec fold accu =
parser
[ [: a = psymb; s :] -> fold (f a accu) s
| [: :] -> accu ]
in
parser [: a = psymb; a = fold (f a e) :] -> a
;
value sfold0sep f e entry symbl psymb psep =
let failed =
fun
[ [symb; sep] -> Fail.symb_failed_txt entry sep symb
| _ -> "failed" ]
in
let rec kont accu =
parser
[ [: () = psep; a = psymb ?? failed symbl; s :] -> kont (f a accu) s
| [: :] -> accu ]
in
parser
[ [: a = psymb; s :] -> kont (f a e) s
| [: :] -> e ]
;
value sfold1sep f e entry symbl psymb psep =
let failed =
fun
[ [symb; sep] -> Fail.symb_failed_txt entry sep symb
| _ -> "failed" ]
in
let parse_top =
fun
[ [symb; _] -> Parse.parse_top_symb entry symb (* FIXME context *)
| _ -> raise Stream.Failure ]
in
let rec kont accu =
parser
[ [: () = psep;
a =
parser
[ [: a = psymb :] -> a
| [: a = parse_top symbl :] -> Obj.magic a
| [: :] -> raise (Stream.Error (failed symbl)) ];
s :] ->
kont (f a accu) s
| [: :] -> accu ]
in
parser [: a = psymb; s :] -> kont (f a e) s
;
end;

30
camlp4/Camlp4/Struct/Grammar/Fold.mli
View File

@ -1,30 +0,0 @@
(* camlp4r *)
(****************************************************************************)
(* *)
(* OCaml *)
(* *)
(* INRIA Rocquencourt *)
(* *)
(* Copyright 2006 Institut National de Recherche en Informatique et *)
(* en Automatique. All rights reserved. This file is distributed under *)
(* the terms of the GNU Library General Public License, with the special *)
(* exception on linking described in LICENSE at the top of the OCaml *)
(* source tree. *)
(* *)
(****************************************************************************)
(* Authors:
* - Daniel de Rauglaudre: initial version
* - Nicolas Pouillard: refactoring
*)
module Make (Structure : Structure.S) : sig
open Structure;
value sfold0 : ('a -> 'b -> 'b) -> 'b -> fold _ 'a 'b;
value sfold1 : ('a -> 'b -> 'b) -> 'b -> fold _ 'a 'b;
value sfold0sep : ('a -> 'b -> 'b) -> 'b -> foldsep _ 'a 'b;
(* value sfold1sep : ('a -> 'b -> 'b) -> 'b -> foldsep _ 'a 'b; *)
end;

323
camlp4/Camlp4/Struct/Grammar/Insert.ml
View File

@ -1,323 +0,0 @@
(* -*- camlp4r -*- *)
(****************************************************************************)
(* *)
(* OCaml *)
(* *)
(* INRIA Rocquencourt *)
(* *)
(* Copyright 2006 Institut National de Recherche en Informatique et *)
(* en Automatique. All rights reserved. This file is distributed under *)
(* the terms of the GNU Library General Public License, with the special *)
(* exception on linking described in LICENSE at the top of the OCaml *)
(* source tree. *)
(* *)
(****************************************************************************)
(* Authors:
* - Daniel de Rauglaudre: initial version
* - Nicolas Pouillard: refactoring
*)
module Make (Structure : Structure.S) = struct
module Tools = Tools.Make Structure;
module Parser = Parser.Make Structure;
open Structure;
open Format;
open Sig.Grammar;
value is_before s1 s2 =
match (s1, s2) with
[ (Skeyword _ | Stoken _, Skeyword _ | Stoken _) -> False
| (Skeyword _ | Stoken _, _) -> True
| _ -> False ]
;
value rec derive_eps =
fun
[ Slist0 _ | Slist0sep _ _ | Sopt _ -> True
| Stry s -> derive_eps s
| Stree t -> tree_derive_eps t
| Slist1 _ | Slist1sep _ _ | Stoken _ | Skeyword _ ->
(* For sure we cannot derive epsilon from these *)
False
| Smeta _ _ _ | Snterm _ | Snterml _ _ | Snext | Sself ->
(* Approximation *)
False ]
and tree_derive_eps =
fun
[ LocAct _ _ -> True
| Node {node = s; brother = bro; son = son} ->
derive_eps s && tree_derive_eps son || tree_derive_eps bro
| DeadEnd -> False ]
;
value empty_lev lname assoc =
let assoc =
match assoc with
[ Some a -> a
| None -> LeftA ]
in
{assoc = assoc; lname = lname; lsuffix = DeadEnd; lprefix = DeadEnd}
;
value change_lev entry lev n lname assoc =
let a =
match assoc with
[ None -> lev.assoc
| Some a ->
do {
if a <> lev.assoc && entry.egram.warning_verbose.val then do {
eprintf "<W> Changing associativity of level \"%s\"\n" n;
flush Pervasives.stderr
}
else ();
a
} ]
in
do {
match lname with
[ Some n ->
if lname <> lev.lname && entry.egram.warning_verbose.val then do {
eprintf "<W> Level label \"%s\" ignored\n" n; flush Pervasives.stderr
}
else ()
| None -> () ];
{assoc = a; lname = lev.lname; lsuffix = lev.lsuffix;
lprefix = lev.lprefix}
}
;
value change_to_self entry =
fun
[ Snterm e when e == entry -> Sself
| x -> x ]
;
value get_level entry position levs =
match position with
[ Some First -> ([], empty_lev, levs)
| Some Last -> (levs, empty_lev, [])
| Some (Level n) ->
let rec get =
fun
[ [] ->
do {
eprintf "No level labelled \"%s\" in entry \"%s\"\n" n
entry.ename;
flush Pervasives.stderr;
failwith "Grammar.extend"
}
| [lev :: levs] ->
if Tools.is_level_labelled n lev then ([], change_lev entry lev n, levs)
else
let (levs1, rlev, levs2) = get levs in
([lev :: levs1], rlev, levs2) ]
in
get levs
| Some (Before n) ->
let rec get =
fun
[ [] ->
do {
eprintf "No level labelled \"%s\" in entry \"%s\"\n" n
entry.ename;
flush Pervasives.stderr;
failwith "Grammar.extend"
}
| [lev :: levs] ->
if Tools.is_level_labelled n lev then ([], empty_lev, [lev :: levs])
else
let (levs1, rlev, levs2) = get levs in
([lev :: levs1], rlev, levs2) ]
in
get levs
| Some (After n) ->
let rec get =
fun
[ [] ->
do {
eprintf "No level labelled \"%s\" in entry \"%s\"\n" n
entry.ename;
flush Pervasives.stderr;
failwith "Grammar.extend"
}
| [lev :: levs] ->
if Tools.is_level_labelled n lev then ([lev], empty_lev, levs)
else
let (levs1, rlev, levs2) = get levs in
([lev :: levs1], rlev, levs2) ]
in
get levs
| None ->
match levs with
[ [lev :: levs] -> ([], change_lev entry lev "<top>", levs)
| [] -> ([], empty_lev, []) ] ]
;
value rec check_gram entry =
fun
[ Snterm e ->
if e.egram != entry.egram then do {
eprintf "\
Error: entries \"%s\" and \"%s\" do not belong to the same grammar.\n"
entry.ename e.ename;
flush Pervasives.stderr;
failwith "Grammar.extend error"
}
else ()
| Snterml e _ ->
if e.egram != entry.egram then do {
eprintf "\
Error: entries \"%s\" and \"%s\" do not belong to the same grammar.\n"
entry.ename e.ename;
flush Pervasives.stderr;
failwith "Grammar.extend error"
}
else ()
| Smeta _ sl _ -> List.iter (check_gram entry) sl
| Slist0sep s t -> do { check_gram entry t; check_gram entry s }
| Slist1sep s t -> do { check_gram entry t; check_gram entry s }
| Slist0 s | Slist1 s | Sopt s | Stry s -> check_gram entry s
| Stree t -> tree_check_gram entry t
| Snext | Sself | Stoken _ | Skeyword _ -> () ]
and tree_check_gram entry =
fun
[ Node {node = n; brother = bro; son = son} ->
do {
check_gram entry n;
tree_check_gram entry bro;
tree_check_gram entry son
}
| LocAct _ _ | DeadEnd -> () ]
;
value get_initial =
fun
[ [Sself :: symbols] -> (True, symbols)
| symbols -> (False, symbols) ]
;
value insert_tokens gram symbols =
let rec insert =
fun
[ Smeta _ sl _ -> List.iter insert sl
| Slist0 s | Slist1 s | Sopt s | Stry s -> insert s
| Slist0sep s t -> do { insert s; insert t }
| Slist1sep s t -> do { insert s; insert t }
| Stree t -> tinsert t
| Skeyword kwd -> using gram kwd
| Snterm _ | Snterml _ _ | Snext | Sself | Stoken _ -> () ]
and tinsert =
fun
[ Node {node = s; brother = bro; son = son} ->
do { insert s; tinsert bro; tinsert son }
| LocAct _ _ | DeadEnd -> () ]
in
List.iter insert symbols
;
value insert_tree entry gsymbols action tree =
let rec insert symbols tree =
match symbols with
[ [s :: sl] -> insert_in_tree s sl tree
| [] ->
match tree with
[ Node {node = s; son = son; brother = bro} ->
Node {node = s; son = son; brother = insert [] bro}
| LocAct old_action action_list ->
let () =
if entry.egram.warning_verbose.val then
eprintf "<W> Grammar extension: in [%s] some rule has been masked@."
entry.ename
else ()
in LocAct action [old_action :: action_list]
| DeadEnd -> LocAct action [] ] ]
and insert_in_tree s sl tree =
match try_insert s sl tree with
[ Some t -> t
| None -> Node {node = s; son = insert sl DeadEnd; brother = tree} ]
and try_insert s sl tree =
match tree with
[ Node {node = s1; son = son; brother = bro} ->
if Tools.eq_symbol s s1 then
let t = Node {node = s1; son = insert sl son; brother = bro} in
Some t
else if is_before s1 s || derive_eps s && not (derive_eps s1) then
let bro =
match try_insert s sl bro with
[ Some bro -> bro
| None ->
Node {node = s; son = insert sl DeadEnd; brother = bro} ]
in
let t = Node {node = s1; son = son; brother = bro} in
Some t
else
match try_insert s sl bro with
[ Some bro ->
let t = Node {node = s1; son = son; brother = bro} in
Some t
| None -> None ]
| LocAct _ _ | DeadEnd -> None ]
in
insert gsymbols tree
;
value insert_level entry e1 symbols action slev =
match e1 with
[ True ->
{assoc = slev.assoc; lname = slev.lname;
lsuffix = insert_tree entry symbols action slev.lsuffix;
lprefix = slev.lprefix}
| False ->
{assoc = slev.assoc; lname = slev.lname; lsuffix = slev.lsuffix;
lprefix = insert_tree entry symbols action slev.lprefix} ]
;
value levels_of_rules entry position rules =
let elev =
match entry.edesc with
[ Dlevels elev -> elev
| Dparser _ ->
do {
eprintf "Error: entry not extensible: \"%s\"\n" entry.ename;
flush Pervasives.stderr;
failwith "Grammar.extend"
} ]
in
if rules = [] then elev
else
let (levs1, make_lev, levs2) = get_level entry position elev in
let (levs, _) =
List.fold_left
(fun (levs, make_lev) (lname, assoc, level) ->
let lev = make_lev lname assoc in
let lev =
List.fold_left
(fun lev (symbols, action) ->
let symbols = List.map (change_to_self entry) symbols in
do {
List.iter (check_gram entry) symbols;
let (e1, symbols) = get_initial symbols;
insert_tokens entry.egram symbols;
insert_level entry e1 symbols action lev
})
lev level
in
([lev :: levs], empty_lev))
([], make_lev) rules
in
levs1 @ List.rev levs @ levs2
;
value extend entry (position, rules) =
let elev = levels_of_rules entry position rules in
do {
entry.edesc := Dlevels elev;
entry.estart :=
fun lev strm ->
let f = Parser.start_parser_of_entry entry in
do { entry.estart := f; f lev strm };
entry.econtinue :=
fun lev bp a strm ->
let f = Parser.continue_parser_of_entry entry in
do { entry.econtinue := f; f lev bp a strm }
};
end;

431
camlp4/Camlp4/Struct/Grammar/Parser.ml
View File

@ -1,431 +0,0 @@
(****************************************************************************)
(* *)
(* OCaml *)
(* *)
(* INRIA Rocquencourt *)
(* *)
(* Copyright 2006 Institut National de Recherche en Informatique et *)
(* en Automatique. All rights reserved. This file is distributed under *)
(* the terms of the GNU Library General Public License, with the special *)
(* exception on linking described in LICENSE at the top of the OCaml *)
(* source tree. *)
(* *)
(****************************************************************************)
(* Authors:
* - Daniel de Rauglaudre: initial version
* - Nicolas Pouillard: refactoring
*)
module Make (Structure : Structure.S) = struct
module Tools = Tools.Make Structure;
module Failed = Failed.Make Structure;
module Print = Print.Make Structure;
open Structure;
open Sig.Grammar;
module StreamOrig = Stream;
value njunk strm n =
for i = 1 to n do Stream.junk strm done;
value loc_bp = Tools.get_cur_loc;
value loc_ep = Tools.get_prev_loc;
value drop_prev_loc = Tools.drop_prev_loc;
value add_loc bp parse_fun strm =
let x = parse_fun strm in
let ep = loc_ep strm in
let loc =
if Loc.start_off bp > Loc.stop_off ep then
(* If nothing has been consumed, create a 0-length location. *)
Loc.join bp
else
Loc.merge bp ep
in
(x, loc);
value stream_peek_nth strm n =
let rec loop i = fun
[ [x :: xs] -> if i = 1 then Some x else loop (i - 1) xs
| [] -> None ]
in
loop n (Stream.npeek n strm);
(* We don't want Stream's functions to be used implictly. *)
module Stream = struct
type t 'a = StreamOrig.t 'a;
exception Failure = StreamOrig.Failure;
exception Error = StreamOrig.Error;
value peek = StreamOrig.peek;
value junk = StreamOrig.junk;
value dup strm =
(* This version of peek_nth is off-by-one from Stream.peek_nth *)
let peek_nth n =
loop n (Stream.npeek (n + 1) strm) where rec loop n =
fun
[ [] -> None
| [x] -> if n = 0 then Some x else None
| [_ :: l] -> loop (n - 1) l ]
in
Stream.from peek_nth;
end;
value try_parser ps strm =
let strm' = Stream.dup strm in
let r =
try ps strm'
with
[ Stream.Error _ | Loc.Exc_located _ (Stream.Error _) ->
raise Stream.Failure
| exc -> raise exc ]
in do {
njunk strm (StreamOrig.count strm');
r;
};
value level_number entry lab =
let rec lookup levn =
fun
[ [] -> failwith ("unknown level " ^ lab)
| [lev :: levs] ->
if Tools.is_level_labelled lab lev then levn else lookup (succ levn) levs ]
in
match entry.edesc with
[ Dlevels elev -> lookup 0 elev
| Dparser _ -> raise Not_found ]
;
value strict_parsing = ref False;
value strict_parsing_warning = ref False;
value rec top_symb entry =
fun
[ Sself | Snext -> Snterm entry
| Snterml e _ -> Snterm e
| Slist1sep s sep -> Slist1sep (top_symb entry s) sep
| _ -> raise Stream.Failure ]
;
value top_tree entry =
fun
[ Node {node = s; brother = bro; son = son} ->
Node {node = top_symb entry s; brother = bro; son = son}
| LocAct _ _ | DeadEnd -> raise Stream.Failure ]
;
value entry_of_symb entry =
fun
[ Sself | Snext -> entry
| Snterm e -> e
| Snterml e _ -> e
| _ -> raise Stream.Failure ]
;
value continue entry loc a s son p1 =
parser
[: a = (entry_of_symb entry s).econtinue 0 loc a;
act = p1 ?? Failed.tree_failed entry a s son :] ->
Action.mk (fun _ -> Action.getf act a)
;
(* PR#4603, PR#4330, PR#4551:
Here loc_bp replaced get_loc_ep to fix all these bugs.
If you do change it again look at these bugs. *)
value skip_if_empty bp strm =
if loc_bp strm = bp then Action.mk (fun _ -> raise Stream.Failure)
else
raise Stream.Failure
;
value do_recover parser_of_tree entry nlevn alevn loc a s son =
parser
[ [: a = parser_of_tree entry nlevn alevn (top_tree entry son) :] -> a
| [: a = skip_if_empty loc :] -> a
| [: a =
continue entry loc a s son
(parser_of_tree entry nlevn alevn son) :] ->
a ]
;
value recover parser_of_tree entry nlevn alevn loc a s son strm =
if strict_parsing.val then raise (Stream.Error (Failed.tree_failed entry a s son))
else
let _ =
if strict_parsing_warning.val then begin
let msg = Failed.tree_failed entry a s son;
Format.eprintf "Warning: trying to recover from syntax error";
if entry.ename <> "" then Format.eprintf " in [%s]" entry.ename else ();
Format.eprintf "\n%s%a@." msg Loc.print loc;
end else () in
do_recover parser_of_tree entry nlevn alevn loc a s son strm
;
value rec parser_of_tree entry nlevn alevn =
fun
[ DeadEnd -> parser []
| LocAct act _ -> parser [: :] -> act
| Node {node = Sself; son = LocAct act _; brother = DeadEnd} ->
parser [: a = entry.estart alevn :] -> Action.getf act a
| Node {node = Sself; son = LocAct act _; brother = bro} ->
let p2 = parser_of_tree entry nlevn alevn bro in
parser
[ [: a = entry.estart alevn :] -> Action.getf act a
| [: a = p2 :] -> a ]
| Node {node = s; son = son; brother = DeadEnd} ->
let tokl =
match s with
[ Stoken _ | Skeyword _ -> Tools.get_token_list entry [] s son
| _ -> None ]
in
match tokl with
[ None ->
let ps = parser_of_symbol entry nlevn s in
let p1 = parser_of_tree entry nlevn alevn son in
let p1 = parser_cont p1 entry nlevn alevn s son in
fun strm ->
let bp = loc_bp strm in
match strm with parser
[: a = ps; act = p1 bp a :] -> Action.getf act a
| Some (tokl, last_tok, son) ->
let p1 = parser_of_tree entry nlevn alevn son in
let p1 = parser_cont p1 entry nlevn alevn last_tok son in
parser_of_token_list p1 tokl ]
| Node {node = s; son = son; brother = bro} ->
let tokl =
match s with
[ Stoken _ | Skeyword _ -> Tools.get_token_list entry [] s son
| _ -> None ]
in
match tokl with
[ None ->
let ps = parser_of_symbol entry nlevn s in
let p1 = parser_of_tree entry nlevn alevn son in
let p1 = parser_cont p1 entry nlevn alevn s son in
let p2 = parser_of_tree entry nlevn alevn bro in
fun strm ->
let bp = loc_bp strm in
match strm with parser
[ [: a = ps; act = p1 bp a :] -> Action.getf act a
| [: a = p2 :] -> a ]
| Some (tokl, last_tok, son) ->
let p1 = parser_of_tree entry nlevn alevn son in
let p1 = parser_cont p1 entry nlevn alevn last_tok son in
let p1 = parser_of_token_list p1 tokl in
let p2 = parser_of_tree entry nlevn alevn bro in
parser
[ [: a = p1 :] -> a
| [: a = p2 :] -> a ] ] ]
and parser_cont p1 entry nlevn alevn s son loc a =
parser
[ [: a = p1 :] -> a
| [: a = recover parser_of_tree entry nlevn alevn loc a s son :] -> a
| [: :] -> raise (Stream.Error (Failed.tree_failed entry a s son)) ]
and parser_of_token_list p1 tokl =
loop 1 tokl where rec loop n =
fun
[ [Stoken (tematch, _) :: tokl] ->
match tokl with
[ [] ->
let ps strm =
match stream_peek_nth strm n with
[ Some (tok, _) when tematch tok -> (njunk strm n; Action.mk tok)
| _ -> raise Stream.Failure ]
in
fun strm ->
let bp = loc_bp strm in
match strm with parser
[: a = ps; act = p1 bp a :] -> Action.getf act a
| _ ->
let ps strm =
match stream_peek_nth strm n with
[ Some (tok, _) when tematch tok -> tok
| _ -> raise Stream.Failure ]
in
let p1 = loop (n + 1) tokl in
parser [: tok = ps; s :] ->
let act = p1 s in Action.getf act tok ]
| [Skeyword kwd :: tokl] ->
match tokl with
[ [] ->
let ps strm =
match stream_peek_nth strm n with
[ Some (tok, _) when Token.match_keyword kwd tok ->
(njunk strm n; Action.mk tok)
| _ -> raise Stream.Failure ]
in
fun strm ->
let bp = loc_bp strm in
match strm with parser
[: a = ps; act = p1 bp a :] -> Action.getf act a
| _ ->
let ps strm =
match stream_peek_nth strm n with
[ Some (tok, _) when Token.match_keyword kwd tok -> tok
| _ -> raise Stream.Failure ]
in
let p1 = loop (n + 1) tokl in
parser [: tok = ps; s :] ->
let act = p1 s in Action.getf act tok ]
| _ -> invalid_arg "parser_of_token_list" ]
and parser_of_symbol entry nlevn =
fun
[ Smeta _ symbl act ->
let act = Obj.magic act entry symbl in
let pl = List.map (parser_of_symbol entry nlevn) symbl in
Obj.magic (List.fold_left (fun act p -> Obj.magic act p) act pl)
| Slist0 s ->
let ps = parser_of_symbol entry nlevn s in
let rec loop al =
parser
[ [: a = ps; s :] -> loop [a :: al] s
| [: :] -> al ]
in
parser [: a = loop [] :] -> Action.mk (List.rev a)
| Slist0sep symb sep ->
let ps = parser_of_symbol entry nlevn symb in
let pt = parser_of_symbol entry nlevn sep in
let rec kont al =
parser
[ [: v = pt; a = ps ?? Failed.symb_failed entry v sep symb;
s :] ->
kont [a :: al] s
| [: :] -> al ]
in
parser
[ [: a = ps; s :] -> Action.mk (List.rev (kont [a] s))
| [: :] -> Action.mk [] ]
| Slist1 s ->
let ps = parser_of_symbol entry nlevn s in
let rec loop al =
parser
[ [: a = ps; s :] -> loop [a :: al] s
| [: :] -> al ]
in
parser [: a = ps; s :] -> Action.mk (List.rev (loop [a] s))
| Slist1sep symb sep ->
let ps = parser_of_symbol entry nlevn symb in
let pt = parser_of_symbol entry nlevn sep in
let rec kont al =
parser
[ [: v = pt;
a =
parser
[ [: a = ps :] -> a
| [: a = parse_top_symb entry symb :] -> a
| [: :] ->
raise (Stream.Error (Failed.symb_failed entry v sep symb)) ];
s :] ->
kont [a :: al] s
| [: :] -> al ]
in
parser [: a = ps; s :] -> Action.mk (List.rev (kont [a] s))
| Sopt s ->
let ps = parser_of_symbol entry nlevn s in
parser
[ [: a = ps :] -> Action.mk (Some a)
| [: :] -> Action.mk None ]
| Stry s ->
let ps = parser_of_symbol entry nlevn s in
try_parser ps
| Stree t ->
let pt = parser_of_tree entry 1 0 t in
fun strm ->
let bp = loc_bp strm in
match strm with parser
[: (act, loc) = add_loc bp pt :] ->
Action.getf act loc
| Snterm e -> parser [: a = e.estart 0 :] -> a
| Snterml e l ->
parser [: a = e.estart (level_number e l) :] -> a
| Sself -> parser [: a = entry.estart 0 :] -> a
| Snext -> parser [: a = entry.estart nlevn :] -> a
| Skeyword kwd ->
parser
[: `(tok, _) when Token.match_keyword kwd tok :] ->
Action.mk tok
| Stoken (f, _) ->
parser
[: `(tok,_) when f tok :] -> Action.mk tok ]
and parse_top_symb entry symb strm =
parser_of_symbol entry 0 (top_symb entry symb) strm;
value rec start_parser_of_levels entry clevn =
fun
[ [] -> fun _ -> parser []
| [lev :: levs] ->
let p1 = start_parser_of_levels entry (succ clevn) levs in
match lev.lprefix with
[ DeadEnd -> p1
| tree ->
let alevn =
match lev.assoc with
[ LeftA | NonA -> succ clevn
| RightA -> clevn ]
in
let p2 = parser_of_tree entry (succ clevn) alevn tree in
match levs with
[ [] ->
fun levn strm ->
let bp = loc_bp strm in
match strm with parser
[: (act, loc) = add_loc bp p2; strm :] ->
let a = Action.getf act loc in
entry.econtinue levn loc a strm
| _ ->
fun levn strm ->
if levn > clevn then p1 levn strm
else
let bp = loc_bp strm in
match strm with parser
[ [: (act, loc) = add_loc bp p2 :] ->
let a = Action.getf act loc in
entry.econtinue levn loc a strm
| [: act = p1 levn :] -> act ] ] ] ]
;
value start_parser_of_entry entry =
debug gram "start_parser_of_entry: @[<2>%a@]@." Print.entry entry in
match entry.edesc with
[ Dlevels [] -> Tools.empty_entry entry.ename
| Dlevels elev -> start_parser_of_levels entry 0 elev
| Dparser p -> fun _ -> p ]
;
value rec continue_parser_of_levels entry clevn =
fun
[ [] -> fun _ _ _ -> parser []
| [lev :: levs] ->
let p1 = continue_parser_of_levels entry (succ clevn) levs in
match lev.lsuffix with
[ DeadEnd -> p1
| tree ->
let alevn =
match lev.assoc with
[ LeftA | NonA -> succ clevn
| RightA -> clevn ]
in
let p2 = parser_of_tree entry (succ clevn) alevn tree in
fun levn bp a strm ->
if levn > clevn then p1 levn bp a strm
else
match strm with parser
[ [: act = p1 levn bp a :] -> act
| [: (act, loc) = add_loc bp p2 :] ->
let a = Action.getf2 act a loc in
entry.econtinue levn loc a strm ] ] ]
;
value continue_parser_of_entry entry =
debug gram "continue_parser_of_entry: @[<2>%a@]@." Print.entry entry in
match entry.edesc with
[ Dlevels elev ->
let p = continue_parser_of_levels entry 0 elev in
fun levn bp a ->
parser
[ [: a = p levn bp a :] -> a
| [: :] -> a ]
| Dparser _ -> fun _ _ _ -> parser [] ]
;
end;

62
camlp4/Camlp4/Struct/Grammar/Parser.mli
View File

@ -1,62 +0,0 @@
(* camlp4r *)
(****************************************************************************)
(* *)
(* OCaml *)
(* *)
(* INRIA Rocquencourt *)
(* *)
(* Copyright 2007 Institut National de Recherche en Informatique et *)
(* en Automatique. All rights reserved. This file is distributed under *)
(* the terms of the GNU Library General Public License, with the special *)
(* exception on linking described in LICENSE at the top of the OCaml *)
(* source tree. *)
(* *)
(****************************************************************************)
(* Authors:
* - Daniel de Rauglaudre: initial version
* - Nicolas Pouillard: refactoring
*)
module Make (Structure : Structure.S) : sig
open Structure;
value add_loc :
Loc.t -> (token_stream -> 'b) -> token_stream -> ('b * Loc.t);
value level_number : internal_entry -> string -> int;
value strict_parsing : ref bool;
value strict_parsing_warning : ref bool;
value top_symb :
internal_entry -> symbol -> symbol;
value top_tree :
internal_entry -> tree -> tree;
value entry_of_symb :
internal_entry -> symbol -> internal_entry;
value continue :
internal_entry -> Loc.t -> Action.t -> symbol -> tree -> efun -> efun;
value do_recover :
(internal_entry -> 'a -> 'b -> tree -> efun) -> internal_entry ->
'a -> 'b -> Loc.t -> Action.t -> symbol -> tree -> efun;
value recover :
(internal_entry -> 'a -> 'b -> tree -> efun) -> internal_entry ->
'a -> 'b -> Loc.t -> Action.t -> symbol -> tree -> efun;
value parser_of_tree :
internal_entry -> int -> int -> tree -> efun;
value parser_cont :
efun -> internal_entry -> int -> int -> symbol -> tree -> Loc.t -> Action.t -> efun;
value parser_of_token_list :
(Loc.t -> Action.t -> efun) -> list symbol -> efun;
value parser_of_symbol :
internal_entry -> int -> symbol -> efun;
value parse_top_symb :
internal_entry -> symbol -> efun;
value start_parser_of_levels :
internal_entry -> int -> list level -> int -> efun;
value start_parser_of_entry :
internal_entry -> int -> efun;
value continue_parser_of_levels :
internal_entry -> int -> list level -> int -> Loc.t -> 'a -> efun;
value continue_parser_of_entry :
internal_entry -> int -> Loc.t -> Action.t -> efun;
end;

270
camlp4/Camlp4/Struct/Grammar/Print.ml
View File

@ -1,270 +0,0 @@
(****************************************************************************)
(* *)
(* OCaml *)
(* *)
(* INRIA Rocquencourt *)
(* *)
(* Copyright 2006 Institut National de Recherche en Informatique et *)
(* en Automatique. All rights reserved. This file is distributed under *)
(* the terms of the GNU Library General Public License, with the special *)
(* exception on linking described in LICENSE at the top of the OCaml *)
(* source tree. *)
(* *)
(****************************************************************************)
(* Authors:
* - Daniel de Rauglaudre: initial version
* - Nicolas Pouillard: refactoring
*)
module Make (Structure : Structure.S) = struct
open Structure;
open Format;
open Sig.Grammar;
value rec flatten_tree =
fun
[ DeadEnd -> []
| LocAct _ _ -> [[]]
| Node {node = n; brother = b; son = s} ->
[ [n :: l] | l <- flatten_tree s ] @ flatten_tree b ];
value rec print_symbol ppf =
fun
[ Smeta n sl _ -> print_meta ppf n sl
| Slist0 s -> fprintf ppf "LIST0 %a" print_symbol1 s
| Slist0sep s t ->
fprintf ppf "LIST0 %a SEP %a" print_symbol1 s print_symbol1 t
| Slist1 s -> fprintf ppf "LIST1 %a" print_symbol1 s
| Slist1sep s t ->
fprintf ppf "LIST1 %a SEP %a" print_symbol1 s print_symbol1 t
| Sopt s -> fprintf ppf "OPT %a" print_symbol1 s
| Stry s -> fprintf ppf "TRY %a" print_symbol1 s
| Snterml e l -> fprintf ppf "%s@ LEVEL@ %S" e.ename l
| Snterm _ | Snext | Sself | Stree _ | Stoken _ | Skeyword _ as s ->
print_symbol1 ppf s ]
and print_meta ppf n sl =
loop 0 sl where rec loop i =
fun
[ [] -> ()
| [s :: sl] ->
let j =
try String.index_from n i ' ' with [ Not_found -> String.length n ]
in
do {
fprintf ppf "%s %a" (String.sub n i (j - i)) print_symbol1 s;
if sl = [] then ()
else do { fprintf ppf " "; loop (min (j + 1) (String.length n)) sl }
} ]
and print_symbol1 ppf =
fun
[ Snterm e -> pp_print_string ppf e.ename
| Sself -> pp_print_string ppf "SELF"
| Snext -> pp_print_string ppf "NEXT"
| Stoken (_, descr) -> pp_print_string ppf descr
| Skeyword s -> fprintf ppf "%S" s
| Stree t -> print_level ppf pp_print_space (flatten_tree t)
| Smeta _ _ _ | Snterml _ _ | Slist0 _ | Slist0sep _ _ | Slist1 _ |
Slist1sep _ _ | Sopt _ | Stry _ as s ->
fprintf ppf "(%a)" print_symbol s ]
and print_rule ppf symbols =
do {
fprintf ppf "@[<hov 0>";
let _ =
List.fold_left
(fun sep symbol ->
do {
fprintf ppf "%t%a" sep print_symbol symbol;
fun ppf -> fprintf ppf ";@ "
})
(fun _ -> ()) symbols
in
fprintf ppf "@]"
}
and print_level ppf pp_print_space rules =
do {
fprintf ppf "@[<hov 0>[ ";
let _ =
List.fold_left
(fun sep rule ->
do {
fprintf ppf "%t%a" sep print_rule rule;
fun ppf -> fprintf ppf "%a| " pp_print_space ()
})
(fun _ -> ()) rules
in
fprintf ppf " ]@]"
}
;
value levels ppf elev =
let _ =
List.fold_left
(fun sep lev ->
let rules =
[ [Sself :: t] | t <- flatten_tree lev.lsuffix ] @
flatten_tree lev.lprefix
in
do {
fprintf ppf "%t@[<hov 2>" sep;
match lev.lname with
[ Some n -> fprintf ppf "%S@;<1 2>" n
| None -> () ];
match lev.assoc with
[ LeftA -> fprintf ppf "LEFTA"
| RightA -> fprintf ppf "RIGHTA"
| NonA -> fprintf ppf "NONA" ];
fprintf ppf "@]@;<1 2>";
print_level ppf pp_force_newline rules;
fun ppf -> fprintf ppf "@,| "
})
(fun _ -> ()) elev
in
();
value entry ppf e =
do {
fprintf ppf "@[<v 0>%s: [ " e.ename;
match e.edesc with
[ Dlevels elev -> levels ppf elev
| Dparser _ -> fprintf ppf "<parser>" ];
fprintf ppf " ]@]"
};
end;
module MakeDump (Structure : Structure.S) = struct
open Structure;
open Format;
open Sig.Grammar;
type brothers = [ Bro of symbol and list brothers ];
value rec print_tree ppf tree =
let rec get_brothers acc =
fun
[ DeadEnd -> List.rev acc
| LocAct _ _ -> List.rev acc
| Node {node = n; brother = b; son = s} -> get_brothers [Bro n (get_brothers [] s) :: acc] b ]
and print_brothers ppf brothers =
if brothers = [] then fprintf ppf "@ []"
else
List.iter (fun [ Bro n xs -> do {
fprintf ppf "@ @[<hv2>- %a" print_symbol n;
match xs with
[ [] -> ()
| [_] -> try print_children ppf (get_children [] xs)
with [ Exit -> fprintf ppf ":%a" print_brothers xs ]
| _ -> fprintf ppf ":%a" print_brothers xs ];
fprintf ppf "@]";
}]) brothers
and print_children ppf = List.iter (fprintf ppf ";@ %a" print_symbol)
and get_children acc =
fun
[ [] -> List.rev acc
| [Bro n x] -> get_children [n::acc] x
| _ -> raise Exit ]
in print_brothers ppf (get_brothers [] tree)
and print_symbol ppf =
fun
[ Smeta n sl _ -> print_meta ppf n sl
| Slist0 s -> fprintf ppf "LIST0 %a" print_symbol1 s
| Slist0sep s t ->
fprintf ppf "LIST0 %a SEP %a" print_symbol1 s print_symbol1 t
| Slist1 s -> fprintf ppf "LIST1 %a" print_symbol1 s
| Slist1sep s t ->
fprintf ppf "LIST1 %a SEP %a" print_symbol1 s print_symbol1 t
| Sopt s -> fprintf ppf "OPT %a" print_symbol1 s
| Stry s -> fprintf ppf "TRY %a" print_symbol1 s
| Snterml e l -> fprintf ppf "%s@ LEVEL@ %S" e.ename l
| Snterm _ | Snext | Sself | Stree _ | Stoken _ | Skeyword _ as s ->
print_symbol1 ppf s ]
and print_meta ppf n sl =
loop 0 sl where rec loop i =
fun
[ [] -> ()
| [s :: sl] ->
let j =
try String.index_from n i ' ' with [ Not_found -> String.length n ]
in
do {
fprintf ppf "%s %a" (String.sub n i (j - i)) print_symbol1 s;
if sl = [] then ()
else do { fprintf ppf " "; loop (min (j + 1) (String.length n)) sl }
} ]
and print_symbol1 ppf =
fun
[ Snterm e -> pp_print_string ppf e.ename
| Sself -> pp_print_string ppf "SELF"
| Snext -> pp_print_string ppf "NEXT"
| Stoken (_, descr) -> pp_print_string ppf descr
| Skeyword s -> fprintf ppf "%S" s
| Stree t -> print_tree ppf t
| Smeta _ _ _ | Snterml _ _ | Slist0 _ | Slist0sep _ _ | Slist1 _ |
Slist1sep _ _ | Sopt _ | Stry _ as s ->
fprintf ppf "(%a)" print_symbol s ]
and print_rule ppf symbols =
do {
fprintf ppf "@[<hov 0>";
let _ =
List.fold_left
(fun sep symbol ->
do {
fprintf ppf "%t%a" sep print_symbol symbol;
fun ppf -> fprintf ppf ";@ "
})
(fun _ -> ()) symbols
in
fprintf ppf "@]"
}
and print_level ppf pp_print_space rules =
do {
fprintf ppf "@[<hov 0>[ ";
let _ =
List.fold_left
(fun sep rule ->
do {
fprintf ppf "%t%a" sep print_rule rule;
fun ppf -> fprintf ppf "%a| " pp_print_space ()
})
(fun _ -> ()) rules
in
fprintf ppf " ]@]"
}
;
value levels ppf elev =
let _ =
List.fold_left
(fun sep lev ->
do {
fprintf ppf "%t@[<v2>" sep;
match lev.lname with
[ Some n -> fprintf ppf "%S@;<1 2>" n
| None -> () ];
match lev.assoc with
[ LeftA -> fprintf ppf "LEFTA"
| RightA -> fprintf ppf "RIGHTA"
| NonA -> fprintf ppf "NONA" ];
fprintf ppf "@]@;<1 2>";
fprintf ppf "@[<v2>suffix:@ ";
print_tree ppf lev.lsuffix;
fprintf ppf "@]@ @[<v2>prefix:@ ";
print_tree ppf lev.lprefix;
fprintf ppf "@]";
fun ppf -> fprintf ppf "@,| "
})
(fun _ -> ()) elev
in
();
value entry ppf e =
do {
fprintf ppf "@[<v 0>%s: [ " e.ename;
match e.edesc with
[ Dlevels elev -> levels ppf elev
| Dparser _ -> fprintf ppf "<parser>" ];
fprintf ppf " ]@]"
};
end;

47
camlp4/Camlp4/Struct/Grammar/Print.mli
View File

@ -1,47 +0,0 @@
(****************************************************************************)
(* *)
(* OCaml *)
(* *)
(* INRIA Rocquencourt *)
(* *)
(* Copyright 2006 Institut National de Recherche en Informatique et *)
(* en Automatique. All rights reserved. This file is distributed under *)
(* the terms of the GNU Library General Public License, with the special *)
(* exception on linking described in LICENSE at the top of the OCaml *)
(* source tree. *)
(* *)
(****************************************************************************)
(* Authors:
* - Daniel de Rauglaudre: initial version
* - Nicolas Pouillard: refactoring
*)
module Make (Structure : Structure.S) : sig
value flatten_tree : Structure.tree -> list (list Structure.symbol);
value print_symbol : Format.formatter -> Structure.symbol -> unit;
value print_meta :
Format.formatter -> string -> list Structure.symbol -> unit;
value print_symbol1 : Format.formatter -> Structure.symbol -> unit;
value print_rule : Format.formatter -> list Structure.symbol -> unit;
value print_level :
Format.formatter ->
(Format.formatter -> unit -> unit) ->
list (list Structure.symbol) -> unit;
value levels : Format.formatter -> list Structure.level -> unit;
value entry : Format.formatter -> Structure.internal_entry -> unit;
end;
module MakeDump (Structure : Structure.S) : sig
value print_symbol : Format.formatter -> Structure.symbol -> unit;
value print_meta :
Format.formatter -> string -> list Structure.symbol -> unit;
value print_symbol1 : Format.formatter -> Structure.symbol -> unit;
value print_rule : Format.formatter -> list Structure.symbol -> unit;
value print_level :
Format.formatter ->
(Format.formatter -> unit -> unit) ->
list (list Structure.symbol) -> unit;
value levels : Format.formatter -> list Structure.level -> unit;
value entry : Format.formatter -> Structure.internal_entry -> unit;
end;

95
camlp4/Camlp4/Struct/Grammar/Search.ml
View File

@ -1,95 +0,0 @@
(****************************************************************************)
(* *)
(* OCaml *)
(* *)
(* INRIA Rocquencourt *)
(* *)
(* Copyright 2006 Institut National de Recherche en Informatique et *)
(* en Automatique. All rights reserved. This file is distributed under *)
(* the terms of the GNU Library General Public License, with the special *)
(* exception on linking described in LICENSE at the top of the OCaml *)
(* source tree. *)
(* *)
(****************************************************************************)
(* Authors:
* - Daniel de Rauglaudre: initial version
* - Nicolas Pouillard: refactoring
*)
module Make (Structure : Structure.S) = struct
open Structure;
value tree_in_entry prev_symb tree =
fun
[ Dlevels levels ->
let rec search_levels =
fun
[ [] -> tree
| [level :: levels] ->
match search_level level with
[ Some tree -> tree
| None -> search_levels levels ] ]
and search_level level =
match search_tree level.lsuffix with
[ Some t -> Some (Node {node = Sself; son = t; brother = DeadEnd})
| None -> search_tree level.lprefix ]
and search_tree t =
if tree <> DeadEnd && t == tree then Some t
else
match t with
[ Node n ->
match search_symbol n.node with
[ Some symb ->
Some (Node {node = symb; son = n.son; brother = DeadEnd})
| None ->
match search_tree n.son with
[ Some t ->
Some (Node {node = n.node; son = t; brother = DeadEnd})
| None -> search_tree n.brother ] ]
| LocAct _ _ | DeadEnd -> None ]
and search_symbol symb =
match symb with
[ Snterm _ | Snterml _ _ | Slist0 _ | Slist0sep _ _ | Slist1 _ |
Slist1sep _ _ | Sopt _ | Stry _ | Stoken _ | Stree _ | Skeyword _
when symb == prev_symb ->
Some symb
| Slist0 symb ->
match search_symbol symb with
[ Some symb -> Some (Slist0 symb)
| None -> None ]
| Slist0sep symb sep ->
match search_symbol symb with
[ Some symb -> Some (Slist0sep symb sep)
| None ->
match search_symbol sep with
[ Some sep -> Some (Slist0sep symb sep)
| None -> None ] ]
| Slist1 symb ->
match search_symbol symb with
[ Some symb -> Some (Slist1 symb)
| None -> None ]
| Slist1sep symb sep ->
match search_symbol symb with
[ Some symb -> Some (Slist1sep symb sep)
| None ->
match search_symbol sep with
[ Some sep -> Some (Slist1sep symb sep)
| None -> None ] ]
| Sopt symb ->
match search_symbol symb with
[ Some symb -> Some (Sopt symb)
| None -> None ]
| Stry symb ->
match search_symbol symb with
[ Some symb -> Some (Stry symb)
| None -> None ]
| Stree t ->
match search_tree t with
[ Some t -> Some (Stree t)
| None -> None ]
| _ -> None ]
in
search_levels levels
| Dparser _ -> tree ]
;
end;

84
camlp4/Camlp4/Struct/Grammar/Static.ml
View File

@ -1,84 +0,0 @@
(****************************************************************************)
(* *)
(* OCaml *)
(* *)
(* INRIA Rocquencourt *)
(* *)
(* Copyright 2006 Institut National de Recherche en Informatique et *)
(* en Automatique. All rights reserved. This file is distributed under *)
(* the terms of the GNU Library General Public License, with the special *)
(* exception on linking described in LICENSE at the top of the OCaml *)
(* source tree. *)
(* *)
(****************************************************************************)
(* Authors:
* - Daniel de Rauglaudre: initial version
* - Nicolas Pouillard: refactoring
*)
value uncurry f (x,y) = f x y;
value flip f x y = f y x;
module Make (Lexer : Sig.Lexer)
: Sig.Grammar.Static with module Loc = Lexer.Loc
and module Token = Lexer.Token
= struct
module Structure = Structure.Make Lexer;
module Delete = Delete.Make Structure;
module Insert = Insert.Make Structure;
module Fold = Fold.Make Structure;
module Tools = Tools.Make Structure;
include Structure;
value gram =
let gkeywords = Hashtbl.create 301 in
{
gkeywords = gkeywords;
gfilter = Token.Filter.mk (Hashtbl.mem gkeywords);
glexer = Lexer.mk ();
warning_verbose = ref True; (* FIXME *)
error_verbose = Camlp4_config.verbose
};
module Entry = struct
module E = Entry.Make Structure;
type t 'a = E.t 'a;
value mk = E.mk gram;
value of_parser name strm = E.of_parser gram name strm;
value setup_parser = E.setup_parser;
value name = E.name;
value print = E.print;
value clear = E.clear;
value dump = E.dump;
value obj x = x;
end;
value get_filter () = gram.gfilter;
value lex loc cs = gram.glexer loc cs;
value lex_string loc str = lex loc (Stream.of_string str);
value filter ts = Tools.keep_prev_loc (Token.Filter.filter gram.gfilter ts);
value parse_tokens_after_filter entry ts = Entry.E.parse_tokens_after_filter entry ts;
value parse_tokens_before_filter entry ts = parse_tokens_after_filter entry (filter ts);
value parse entry loc cs = parse_tokens_before_filter entry (lex loc cs);
value parse_string entry loc str = parse_tokens_before_filter entry (lex_string loc str);
value delete_rule = Delete.delete_rule;
value srules e rl =
Stree (List.fold_left (flip (uncurry (Insert.insert_tree e))) DeadEnd rl);
value sfold0 = Fold.sfold0;
value sfold1 = Fold.sfold1;
value sfold0sep = Fold.sfold0sep;
(* value sfold1sep = Fold.sfold1sep; *)
value extend = Insert.extend;
end;

294
camlp4/Camlp4/Struct/Grammar/Structure.ml
View File

@ -1,294 +0,0 @@
(****************************************************************************)
(* *)
(* OCaml *)
(* *)
(* INRIA Rocquencourt *)
(* *)
(* Copyright 2006 Institut National de Recherche en Informatique et *)
(* en Automatique. All rights reserved. This file is distributed under *)
(* the terms of the GNU Library General Public License, with the special *)
(* exception on linking described in LICENSE at the top of the OCaml *)
(* source tree. *)
(* *)
(****************************************************************************)
(* Authors:
* - Daniel de Rauglaudre: initial version
* - Nicolas Pouillard: refactoring
*)
open Sig.Grammar;
module type S = sig
module Loc : Sig.Loc;
module Token : Sig.Token with module Loc = Loc;
module Lexer : Sig.Lexer
with module Loc = Loc
and module Token = Token;
module Action : Sig.Grammar.Action;
type gram =
{ gfilter : Token.Filter.t;
gkeywords : Hashtbl.t string (ref int);
glexer : Loc.t -> Stream.t char -> Stream.t (Token.t * Loc.t);
warning_verbose : ref bool;
error_verbose : ref bool };
type token_info = { prev_loc : Loc.t
; cur_loc : Loc.t
; prev_loc_only : bool
};
type token_stream = Stream.t (Token.t * token_info);
type efun = token_stream -> Action.t;
type token_pattern = ((Token.t -> bool) * string);
type internal_entry =
{ egram : gram;
ename : string;
estart : mutable int -> efun;
econtinue : mutable int -> Loc.t -> Action.t -> efun;
edesc : mutable desc }
and desc =
[ Dlevels of list level
| Dparser of token_stream -> Action.t ]
and level =
{ assoc : assoc ;
lname : option string ;
lsuffix : tree ;
lprefix : tree }
and symbol =
[ Smeta of string and list symbol and Action.t
| Snterm of internal_entry
| Snterml of internal_entry and string
| Slist0 of symbol
| Slist0sep of symbol and symbol
| Slist1 of symbol
| Slist1sep of symbol and symbol
| Sopt of symbol
| Stry of symbol
| Sself
| Snext
| Stoken of token_pattern
| Skeyword of string
| Stree of tree ]
and tree =
[ Node of node
| LocAct of Action.t and list Action.t
| DeadEnd ]
and node =
{ node : symbol ;
son : tree ;
brother : tree };
type production_rule = (list symbol * Action.t);
type single_extend_statment =
(option string * option assoc * list production_rule);
type extend_statment =
(option position * list single_extend_statment);
type delete_statment = list symbol;
type fold 'a 'b 'c =
internal_entry -> list symbol ->
(Stream.t 'a -> 'b) -> Stream.t 'a -> 'c;
type foldsep 'a 'b 'c =
internal_entry -> list symbol ->
(Stream.t 'a -> 'b) -> (Stream.t 'a -> unit) -> Stream.t 'a -> 'c;
(* Accessors *)
value get_filter : gram -> Token.Filter.t;
(* Useful functions *)
value using : gram -> string -> unit;
value removing : gram -> string -> unit;
end;
module Make (Lexer : Sig.Lexer) = struct
module Loc = Lexer.Loc;
module Token = Lexer.Token;
module Action : Sig.Grammar.Action = struct
type t = Obj.t ;
value mk = Obj.repr;
value get = Obj.obj ;
value getf = Obj.obj ;
value getf2 = Obj.obj ;
end;
module Lexer = Lexer;
type gram =
{ gfilter : Token.Filter.t;
gkeywords : Hashtbl.t string (ref int);
glexer : Loc.t -> Stream.t char -> Stream.t (Token.t * Loc.t);
warning_verbose : ref bool;
error_verbose : ref bool };
type token_info = { prev_loc : Loc.t
; cur_loc : Loc.t
; prev_loc_only : bool
};
type token_stream = Stream.t (Token.t * token_info);
type efun = token_stream -> Action.t;
type token_pattern = ((Token.t -> bool) * string);
type internal_entry =
{ egram : gram;
ename : string;
estart : mutable int -> efun;
econtinue : mutable int -> Loc.t -> Action.t -> efun;
edesc : mutable desc }
and desc =
[ Dlevels of list level
| Dparser of token_stream -> Action.t ]
and level =
{ assoc : assoc ;
lname : option string ;
lsuffix : tree ;
lprefix : tree }
and symbol =
[ Smeta of string and list symbol and Action.t
| Snterm of internal_entry
| Snterml of internal_entry and string
| Slist0 of symbol
| Slist0sep of symbol and symbol
| Slist1 of symbol
| Slist1sep of symbol and symbol
| Sopt of symbol
| Stry of symbol
| Sself
| Snext
| Stoken of token_pattern
| Skeyword of string
| Stree of tree ]
and tree =
[ Node of node
| LocAct of Action.t and list Action.t
| DeadEnd ]
and node =
{ node : symbol ;
son : tree ;
brother : tree };
type production_rule = (list symbol * Action.t);
type single_extend_statment =
(option string * option assoc * list production_rule);
type extend_statment =
(option position * list single_extend_statment);
type delete_statment = list symbol;
type fold 'a 'b 'c =
internal_entry -> list symbol ->
(Stream.t 'a -> 'b) -> Stream.t 'a -> 'c;
type foldsep 'a 'b 'c =
internal_entry -> list symbol ->
(Stream.t 'a -> 'b) -> (Stream.t 'a -> unit) -> Stream.t 'a -> 'c;
value get_filter g = g.gfilter;
value token_location r = r.cur_loc;
type not_filtered 'a = 'a;
value using { gkeywords = table; gfilter = filter } kwd =
let r = try Hashtbl.find table kwd with
[ Not_found ->
let r = ref 0 in do { Hashtbl.add table kwd r; r } ]
in do { Token.Filter.keyword_added filter kwd (r.val = 0);
incr r };
value removing { gkeywords = table; gfilter = filter } kwd =
let r = Hashtbl.find table kwd in
let () = decr r in
if r.val = 0 then do {
Token.Filter.keyword_removed filter kwd;
Hashtbl.remove table kwd
} else ();
end;
(*
value iter_entry f e =
let treated = ref [] in
let rec do_entry e =
if List.memq e treated.val then ()
else do {
treated.val := [e :: treated.val];
f e;
match e.edesc with
[ Dlevels ll -> List.iter do_level ll
| Dparser _ -> () ]
}
and do_level lev = do { do_tree lev.lsuffix; do_tree lev.lprefix }
and do_tree =
fun
[ Node n -> do_node n
| LocAct _ _ | DeadEnd -> () ]
and do_node n = do { do_symbol n.node; do_tree n.son; do_tree n.brother }
and do_symbol =
fun
[ Smeta _ sl _ -> List.iter do_symbol sl
| Snterm e | Snterml e _ -> do_entry e
| Slist0 s | Slist1 s | Sopt s | Stry s -> do_symbol s
| Slist0sep s1 s2 | Slist1sep s1 s2 -> do { do_symbol s1; do_symbol s2 }
| Stree t -> do_tree t
| Sself | Snext | Stoken _ | Stoken_fun _ -> () ]
in
do_entry e
;
value fold_entry f e init =
let treated = ref [] in
let rec do_entry accu e =
if List.memq e treated.val then accu
else do {
treated.val := [e :: treated.val];
let accu = f e accu in
match e.edesc with
[ Dlevels ll -> List.fold_left do_level accu ll
| Dparser _ -> accu ]
}
and do_level accu lev =
let accu = do_tree accu lev.lsuffix in
do_tree accu lev.lprefix
and do_tree accu =
fun
[ Node n -> do_node accu n
| LocAct _ _ | DeadEnd -> accu ]
and do_node accu n =
let accu = do_symbol accu n.node in
let accu = do_tree accu n.son in
do_tree accu n.brother
and do_symbol accu =
fun
[ Smeta _ sl _ -> List.fold_left do_symbol accu sl
| Snterm e | Snterml e _ -> do_entry accu e
| Slist0 s | Slist1 s | Sopt s | Stry s -> do_symbol accu s
| Slist0sep s1 s2 | Slist1sep s1 s2 ->
let accu = do_symbol accu s1 in
do_symbol accu s2
| Stree t -> do_tree accu t
| Sself | Snext | Stoken _ | Stoken_fun _ -> accu ]
in
do_entry init e
;
value is_level_labelled n lev =
match lev.lname with
[ Some n1 -> n = n1
| None -> False ]
;
value tokens g con =
let list = ref [] in
do {
Hashtbl.iter
(fun (p_con, p_prm) c ->
if p_con = con then list.val := [(p_prm, c.val) :: list.val] else ())
g.gtokens;
list.val
}
;
*)

132
camlp4/Camlp4/Struct/Grammar/Tools.ml
View File

@ -1,132 +0,0 @@
(****************************************************************************)
(* *)
(* OCaml *)
(* *)
(* INRIA Rocquencourt *)
(* *)
(* Copyright 2006 Institut National de Recherche en Informatique et *)
(* en Automatique. All rights reserved. This file is distributed under *)
(* the terms of the GNU Library General Public License, with the special *)
(* exception on linking described in LICENSE at the top of the OCaml *)
(* source tree. *)
(* *)
(****************************************************************************)
(* Authors:
* - Daniel de Rauglaudre: initial version
* - Nicolas Pouillard: refactoring
*)
(* PR#5090: don't do lookahead on get_prev_loc. *)
value get_prev_loc_only = ref False;
module Make (Structure : Structure.S) = struct
open Structure;
value empty_entry ename _ =
raise (Stream.Error ("entry [" ^ ename ^ "] is empty"));
value rec stream_map f = parser
[ [: ` x; strm :] -> [: ` (f x); stream_map f strm :]
| [: :] -> [: :] ];
value keep_prev_loc strm =
match Stream.peek strm with
[ None -> [: :]
| Some (tok0,init_loc) ->
let rec go prev_loc strm1 =
if get_prev_loc_only.val then
[: `(tok0, {prev_loc; cur_loc = prev_loc; prev_loc_only = True});
go prev_loc strm1 :]
else
match strm1 with parser
[ [: `(tok,cur_loc); strm :] ->
[: `(tok, {prev_loc; cur_loc; prev_loc_only = False});
go cur_loc strm :]
| [: :] -> [: :] ]
in go init_loc strm ];
value drop_prev_loc strm = stream_map (fun (tok,r) -> (tok,r.cur_loc)) strm;
value get_cur_loc strm =
match Stream.peek strm with
[ Some (_,r) -> r.cur_loc
| None -> Loc.ghost ];
value get_prev_loc strm =
begin
get_prev_loc_only.val := True;
let result = match Stream.peek strm with
[ Some (_, {prev_loc; prev_loc_only = True}) ->
begin Stream.junk strm; prev_loc end
| Some (_, {prev_loc; prev_loc_only = False}) -> prev_loc
| None -> Loc.ghost ];
get_prev_loc_only.val := False;
result
end;
value is_level_labelled n lev =
match lev.lname with
[ Some n1 -> n = n1
| None -> False ];
value warning_verbose = ref True;
value rec get_token_list entry tokl last_tok tree =
match tree with
[ Node {node = (Stoken _ | Skeyword _ as tok); son = son; brother = DeadEnd} ->
get_token_list entry [last_tok :: tokl] tok son
| _ ->
if tokl = [] then None
else Some (List.rev [last_tok :: tokl], last_tok, tree) ];
value is_antiquot s =
let len = String.length s in
len > 1 && s.[0] = '$';
value eq_Stoken_ids s1 s2 =
not (is_antiquot s1) && not (is_antiquot s2) && s1 = s2;
value logically_eq_symbols entry =
let rec eq_symbols s1 s2 =
match (s1, s2) with
[ (Snterm e1, Snterm e2) -> e1.ename = e2.ename
| (Snterm e1, Sself) -> e1.ename = entry.ename
| (Sself, Snterm e2) -> entry.ename = e2.ename
| (Snterml e1 l1, Snterml e2 l2) -> e1.ename = e2.ename && l1 = l2
| (Slist0 s1, Slist0 s2) |
(Slist1 s1, Slist1 s2) |
(Sopt s1, Sopt s2) |
(Stry s1, Stry s2) -> eq_symbols s1 s2
| (Slist0sep s1 sep1, Slist0sep s2 sep2) |
(Slist1sep s1 sep1, Slist1sep s2 sep2) ->
eq_symbols s1 s2 && eq_symbols sep1 sep2
| (Stree t1, Stree t2) -> eq_trees t1 t2
| (Stoken (_, s1), Stoken (_, s2)) -> eq_Stoken_ids s1 s2
| _ -> s1 = s2 ]
and eq_trees t1 t2 =
match (t1, t2) with
[ (Node n1, Node n2) ->
eq_symbols n1.node n2.node && eq_trees n1.son n2.son &&
eq_trees n1.brother n2.brother
| (LocAct _ _ | DeadEnd, LocAct _ _ | DeadEnd) -> True
| _ -> False ]
in
eq_symbols;
value rec eq_symbol s1 s2 =
match (s1, s2) with
[ (Snterm e1, Snterm e2) -> e1 == e2
| (Snterml e1 l1, Snterml e2 l2) -> e1 == e2 && l1 = l2
| (Slist0 s1, Slist0 s2) |
(Slist1 s1, Slist1 s2) |
(Sopt s1, Sopt s2) |
(Stry s1, Stry s2) -> eq_symbol s1 s2
| (Slist0sep s1 sep1, Slist0sep s2 sep2) |
(Slist1sep s1 sep1, Slist1sep s2 sep2) ->
eq_symbol s1 s2 && eq_symbol sep1 sep2
| (Stree _, Stree _) -> False
| (Stoken (_, s1), Stoken (_, s2)) -> eq_Stoken_ids s1 s2
| _ -> s1 = s2 ]
;
end;

496
camlp4/Camlp4/Struct/Lexer.mll
View File

@ -1,496 +0,0 @@
(****************************************************************************)
(* *)
(* OCaml *)
(* *)
(* INRIA Rocquencourt *)
(* *)
(* Copyright 2006-2006 Institut National de Recherche en Informatique et *)
(* en Automatique. All rights reserved. This file is distributed under *)
(* the terms of the GNU Library General Public License, with the special *)
(* exception on linking described in LICENSE at the top of the OCaml *)
(* source tree. *)
(* *)
(****************************************************************************)
(* Authors:
* - Daniel de Rauglaudre: initial version
* - Nicolas Pouillard: refactoring
*)
(* The lexer definition *)
{
(** A lexical analyzer. *)
(* FIXME interface module Make (Token : Token) |+ Note that this Token sig is not in Sig +| *)
(* : Sig.Lexer. S with module Loc = Token.Loc and module Token = Token; *)
(* type context =
{ loc : Loc.t ;
in_comment : bool ;
|+* FIXME When True, all lexers built by [Plexer.make ()] do not lex the
quotation syntax any more. Default is False (quotations are
lexed). +|
quotations : bool };
value default_context : context;
value mk : Loc.t -> Stream.t char -> Stream.t (Token.t * Loc.t);
value mk' : context -> Stream.t char -> Stream.t (Token.t * Loc.t); *)
(* FIXME Beware the context argument must be given like that:
* mk' { (default_context) with ... = ... } strm
*)
module TokenEval = Token.Eval
module Make (Token : Sig.Camlp4Token)
= struct
module Loc = Token.Loc
module Token = Token
open Lexing
open Sig
(* Error report *)
module Error = struct
type t =
| Illegal_character of char
| Illegal_escape of string
| Unterminated_comment
| Unterminated_string
| Unterminated_quotation
| Unterminated_antiquot
| Unterminated_string_in_comment
| Comment_start
| Comment_not_end
| Literal_overflow of string
exception E of t
open Format
let print ppf =
function
| Illegal_character c ->
fprintf ppf "Illegal character (%s)" (Char.escaped c)
| Illegal_escape s ->
fprintf ppf "Illegal backslash escape in string or character (%s)" s
| Unterminated_comment ->
fprintf ppf "Comment not terminated"
| Unterminated_string ->
fprintf ppf "String literal not terminated"
| Unterminated_string_in_comment ->
fprintf ppf "This comment contains an unterminated string literal"
| Unterminated_quotation ->
fprintf ppf "Quotation not terminated"
| Unterminated_antiquot ->
fprintf ppf "Antiquotation not terminated"
| Literal_overflow ty ->
fprintf ppf "Integer literal exceeds the range of representable integers of type %s" ty
| Comment_start ->
fprintf ppf "this is the start of a comment"
| Comment_not_end ->
fprintf ppf "this is not the end of a comment"
let to_string x =
let b = Buffer.create 50 in
let () = bprintf b "%a" print x in Buffer.contents b
end;;
let module M = ErrorHandler.Register(Error) in ()
open Error
(* To store some context information:
* loc : position of the beginning of a string, quotation and comment
* in_comment: are we in a comment?
* quotations: shall we lex quotation?
* If quotations is false it's a SYMBOL token.
* antiquots : shall we lex antiquotations.
*)
type context =
{ loc : Loc.t ;
in_comment : bool ;
quotations : bool ;
antiquots : bool ;
lexbuf : lexbuf ;
buffer : Buffer.t }
let default_context lb =
{ loc = Loc.ghost ;
in_comment = false ;
quotations = true ;
antiquots = false ;
lexbuf = lb ;
buffer = Buffer.create 256 }
(* To buffer string literals, quotations and antiquotations *)
let store c = Buffer.add_string c.buffer (Lexing.lexeme c.lexbuf)
let istore_char c i = Buffer.add_char c.buffer (Lexing.lexeme_char c.lexbuf i)
let buff_contents c =
let contents = Buffer.contents c.buffer in
Buffer.reset c.buffer; contents
let loc c = Loc.merge c.loc (Loc.of_lexbuf c.lexbuf)
let quotations c = c.quotations
let antiquots c = c.antiquots
let is_in_comment c = c.in_comment
let in_comment c = { (c) with in_comment = true }
let set_start_p c = c.lexbuf.lex_start_p <- Loc.start_pos c.loc
let move_start_p shift c = (* FIXME Please see PR#5820*)
let p = c.lexbuf.lex_start_p in
c.lexbuf.lex_start_p <- { (p) with pos_cnum = p.pos_cnum + shift }
let update_loc c = { (c) with loc = Loc.of_lexbuf c.lexbuf }
let with_curr_loc f c = f (update_loc c) c.lexbuf
let parse_nested f c =
with_curr_loc f c;
set_start_p c;
buff_contents c
let shift n c = { (c) with loc = Loc.move `both n c.loc }
let store_parse f c = store c ; f c c.lexbuf
let parse f c = f c c.lexbuf
let mk_quotation quotation c name loc shift =
let s = parse_nested quotation (update_loc c) in
let contents = String.sub s 0 (String.length s - 2) in
QUOTATION { q_name = name ;
q_loc = loc ;
q_shift = shift ;
q_contents = contents }
(* Update the current location with file name and line number. *)
let update_loc c file line absolute chars =
let lexbuf = c.lexbuf in
let pos = lexbuf.lex_curr_p in
let new_file = match file with
| None -> pos.pos_fname
| Some s -> s
in
lexbuf.lex_curr_p <- { pos with
pos_fname = new_file;
pos_lnum = if absolute then line else pos.pos_lnum + line;
pos_bol = pos.pos_cnum - chars;
}
(* To convert integer literals, copied from "../parsing/lexer.mll" *)
let cvt_int_literal s =
- int_of_string ("-" ^ s)
let cvt_int32_literal s =
Int32.neg (Int32.of_string ("-" ^ s))
let cvt_int64_literal s =
Int64.neg (Int64.of_string ("-" ^ s))
let cvt_nativeint_literal s =
Nativeint.neg (Nativeint.of_string ("-" ^ s))
let err error loc =
raise(Loc.Exc_located(loc, Error.E error))
let warn error loc =
Format.eprintf "Warning: %a: %a@." Loc.print loc Error.print error
}
let newline = ('\010' | '\013' | "\013\010")
let blank = [' ' '\009' '\012']
let lowercase = ['a'-'z' '\223'-'\246' '\248'-'\255' '_']
let uppercase = ['A'-'Z' '\192'-'\214' '\216'-'\222']
let identchar =
['A'-'Z' 'a'-'z' '_' '\192'-'\214' '\216'-'\246' '\248'-'\255' '\'' '0'-'9']
let ident = (lowercase|uppercase) identchar*
let locname = ident
let not_star_symbolchar =
['$' '!' '%' '&' '+' '-' '.' '/' ':' '<' '=' '>' '?' '@' '^' '|' '~' '\\']
let symbolchar = '*' | not_star_symbolchar
let quotchar =
['!' '%' '&' '+' '-' '.' '/' ':' '=' '?' '@' '^' '|' '~' '\\' '*']
let hexa_char = ['0'-'9' 'A'-'F' 'a'-'f']
let decimal_literal =
['0'-'9'] ['0'-'9' '_']*
let hex_literal =
'0' ['x' 'X'] hexa_char ['0'-'9' 'A'-'F' 'a'-'f' '_']*
let oct_literal =
'0' ['o' 'O'] ['0'-'7'] ['0'-'7' '_']*
let bin_literal =
'0' ['b' 'B'] ['0'-'1'] ['0'-'1' '_']*
let int_literal =
decimal_literal | hex_literal | oct_literal | bin_literal
let float_literal =
['0'-'9'] ['0'-'9' '_']*
('.' ['0'-'9' '_']* )?
(['e' 'E'] ['+' '-']? ['0'-'9'] ['0'-'9' '_']*)?
(* Delimitors are extended (from 3.09) in a conservative way *)
(* These chars that can't start an expression or a pattern: *)
let safe_delimchars = ['%' '&' '/' '@' '^']
(* These symbols are unsafe since "[<", "[|", etc. exsist. *)
let delimchars = safe_delimchars | ['|' '<' '>' ':' '=' '.']
let left_delims = ['(' '[' '{']
let right_delims = [')' ']' '}']
let left_delimitor =
(* At least a safe_delimchars *)
left_delims delimchars* safe_delimchars (delimchars|left_delims)*
(* A '(' or a new super '(' without "(<" *)
| '(' (['|' ':'] delimchars*)?
(* Old brackets, no new brackets starting with "[|" or "[:" *)
| '[' ['|' ':']?
(* Old "[<","{<" and new ones *)
| ['[' '{'] delimchars* '<'
(* Old brace and new ones *)
| '{' (['|' ':'] delimchars*)?
let right_delimitor =
(* At least a safe_delimchars *)
(delimchars|right_delims)* safe_delimchars (delimchars|right_delims)* right_delims
(* A ')' or a new super ')' without ">)" *)
| (delimchars* ['|' ':'])? ')'
(* Old brackets, no new brackets ending with "|]" or ":]" *)
| ['|' ':']? ']'
(* Old ">]",">}" and new ones *)
| '>' delimchars* [']' '}']
(* Old brace and new ones *)
| (delimchars* ['|' ':'])? '}'
rule token c = parse
| newline { update_loc c None 1 false 0; NEWLINE }
| blank + as x { BLANKS x }
| "~" (lowercase identchar * as x) ':' { LABEL x }
| "?" (lowercase identchar * as x) ':' { OPTLABEL x }
| lowercase identchar * as x { LIDENT x }
| uppercase identchar * as x { UIDENT x }
| int_literal as i
{ try INT(cvt_int_literal i, i)
with Failure _ -> err (Literal_overflow "int") (Loc.of_lexbuf lexbuf) }
| float_literal as f
{ try FLOAT(float_of_string f, f)
with Failure _ -> err (Literal_overflow "float") (Loc.of_lexbuf lexbuf) }
| (int_literal as i) "l"
{ try INT32(cvt_int32_literal i, i)
with Failure _ -> err (Literal_overflow "int32") (Loc.of_lexbuf lexbuf) }
| (int_literal as i) "L"
{ try INT64(cvt_int64_literal i, i)
with Failure _ -> err (Literal_overflow "int64") (Loc.of_lexbuf lexbuf) }
| (int_literal as i) "n"
{ try NATIVEINT(cvt_nativeint_literal i, i)
with Failure _ -> err (Literal_overflow "nativeint") (Loc.of_lexbuf lexbuf) }
| '"'
{ with_curr_loc string c;
let s = buff_contents c in STRING (TokenEval.string s, s) }
| "'" (newline as x) "'"
{ update_loc c None 1 false 1; CHAR (TokenEval.char x, x) }
| "'" ( [^ '\\' '\010' '\013']
| '\\' (['\\' '"' 'n' 't' 'b' 'r' ' ' '\'']
|['0'-'9'] ['0'-'9'] ['0'-'9']
|'x' hexa_char hexa_char)
as x) "'" { CHAR (TokenEval.char x, x) }
| "'\\" (_ as c)
{ err (Illegal_escape (String.make 1 c)) (Loc.of_lexbuf lexbuf) }
| "(*"
{ store c; COMMENT(parse_nested comment (in_comment c)) }
| "(*)"
{ warn Comment_start (Loc.of_lexbuf lexbuf) ;
parse comment (in_comment c); COMMENT (buff_contents c) }
| "*)"
{ warn Comment_not_end (Loc.of_lexbuf lexbuf) ;
c.lexbuf.lex_curr_pos <- c.lexbuf.lex_curr_pos - 1;
SYMBOL "*" }
| "<<" (quotchar* as beginning)
{ if quotations c
then (move_start_p (-String.length beginning);
mk_quotation quotation c "" "" 2)
else parse (symbolchar_star ("<<" ^ beginning)) c }
| "<<>>"
{ if quotations c
then QUOTATION { q_name = ""; q_loc = ""; q_shift = 2; q_contents = "" }
else parse (symbolchar_star "<<>>") c }
| "<@"
{ if quotations c then with_curr_loc maybe_quotation_at c
else parse (symbolchar_star "<@") c }
| "<:"
{ if quotations c then with_curr_loc maybe_quotation_colon c
else parse (symbolchar_star "<:") c }
| "#" [' ' '\t']* (['0'-'9']+ as num) [' ' '\t']*
("\"" ([^ '\010' '\013' '"' ] * as name) "\"")?
[^ '\010' '\013'] * newline
{ let inum = int_of_string num
in update_loc c name inum true 0; LINE_DIRECTIVE(inum, name) }
| '(' (not_star_symbolchar as op) ')'
{ ESCAPED_IDENT (String.make 1 op) }
| '(' (not_star_symbolchar symbolchar* not_star_symbolchar as op) ')'
{ ESCAPED_IDENT op }
| '(' (not_star_symbolchar symbolchar* as op) blank+ ')'
{ ESCAPED_IDENT op }
| '(' blank+ (symbolchar* not_star_symbolchar as op) ')'
{ ESCAPED_IDENT op }
| '(' blank+ (symbolchar+ as op) blank+ ')'
{ ESCAPED_IDENT op }
| ( "#" | "`" | "'" | "," | "." | ".." | ":" | "::"
| ":=" | ":>" | ";" | ";;" | "_"
| left_delimitor | right_delimitor ) as x { SYMBOL x }
| '$' { if antiquots c
then with_curr_loc dollar (shift 1 c)
else parse (symbolchar_star "$") c }
| ['~' '?' '!' '=' '<' '>' '|' '&' '@' '^' '+' '-' '*' '/' '%' '\\'] symbolchar *
as x { SYMBOL x }
| eof
{ let pos = lexbuf.lex_curr_p in
lexbuf.lex_curr_p <- { pos with pos_bol = pos.pos_bol + 1 ;
pos_cnum = pos.pos_cnum + 1 }; EOI }
| _ as c { err (Illegal_character c) (Loc.of_lexbuf lexbuf) }
and comment c = parse
"(*"
{ store c; with_curr_loc comment c; parse comment c }
| "*)" { store c }
| '<' (':' ident)? ('@' locname)? '<'
{ store c;
if quotations c then with_curr_loc quotation c; parse comment c }
| ident { store_parse comment c }
| "\""
{ store c;
begin try with_curr_loc string c
with Loc.Exc_located(_, Error.E Unterminated_string) ->
err Unterminated_string_in_comment (loc c)
end;
Buffer.add_char c.buffer '"';
parse comment c }
| "''" { store_parse comment c }
| "'''" { store_parse comment c }
| "'" newline "'"
{ update_loc c None 1 false 1; store_parse comment c }
| "'" [^ '\\' '\'' '\010' '\013' ] "'" { store_parse comment c }
| "'\\" ['\\' '"' '\'' 'n' 't' 'b' 'r' ' '] "'" { store_parse comment c }
| "'\\" ['0'-'9'] ['0'-'9'] ['0'-'9'] "'" { store_parse comment c }
| "'\\" 'x' hexa_char hexa_char "'" { store_parse comment c }
| eof
{ err Unterminated_comment (loc c) }
| newline
{ update_loc c None 1 false 0; store_parse comment c }
| _ { store_parse comment c }
and string c = parse
'"' { set_start_p c }
| '\\' newline ([' ' '\t'] * as space)
{ update_loc c None 1 false (String.length space);
store_parse string c }
| '\\' ['\\' '"' 'n' 't' 'b' 'r' ' ' '\''] { store_parse string c }
| '\\' ['0'-'9'] ['0'-'9'] ['0'-'9'] { store_parse string c }
| '\\' 'x' hexa_char hexa_char { store_parse string c }
| '\\' (_ as x)
{ if is_in_comment c
then store_parse string c
else begin
warn (Illegal_escape (String.make 1 x)) (Loc.of_lexbuf lexbuf);
store_parse string c
end }
| newline
{ update_loc c None 1 false 0; store_parse string c }
| eof { err Unterminated_string (loc c) }
| _ { store_parse string c }
and symbolchar_star beginning c = parse
| symbolchar* as tok { move_start_p (-String.length beginning) c ;
SYMBOL(beginning ^ tok) }
and maybe_quotation_at c = parse
| (ident as loc) '<'
{ mk_quotation quotation c "" loc (1 + String.length loc) }
| symbolchar* as tok { SYMBOL("<@" ^ tok) }
and maybe_quotation_colon c = parse
| (ident as name) '<'
{ mk_quotation quotation c name "" (1 + String.length name) }
| (ident as name) '@' (locname as loc) '<'
{ mk_quotation quotation c name loc
(2 + String.length loc + String.length name) }
| symbolchar* as tok { SYMBOL("<:" ^ tok) }
and quotation c = parse
| '<' (':' ident)? ('@' locname)? '<' { store c ;
with_curr_loc quotation c ;
parse quotation c }
| ">>" { store c }
| eof { err Unterminated_quotation (loc c) }
| newline { update_loc c None 1 false 0 ;
store_parse quotation c }
| _ { store_parse quotation c }
and dollar c = parse
| '$' { set_start_p c; ANTIQUOT("", "") }
| ('`'? (identchar*|['.' '!']+) as name) ':'
{ with_curr_loc (antiquot name) (shift (1 + String.length name) c) }
| _ { store_parse (antiquot "") c }
and antiquot name c = parse
| '$' { set_start_p c; ANTIQUOT(name, buff_contents c) }
| eof { err Unterminated_antiquot (loc c) }
| newline
{ update_loc c None 1 false 0; store_parse (antiquot name) c }
| '<' (':' ident)? ('@' locname)? '<'
{ store c; with_curr_loc quotation c; parse (antiquot name) c }
| _ { store_parse (antiquot name) c }
{
let lexing_store s buff max =
let rec self n s =
if n >= max then n
else
match Stream.peek s with
| Some x ->
Stream.junk s;
buff.[n] <- x;
succ n
| _ -> n
in
self 0 s
let from_context c =
let next _ =
let tok = with_curr_loc token c in
let loc = Loc.of_lexbuf c.lexbuf in
Some ((tok, loc))
in Stream.from next
let from_lexbuf ?(quotations = true) lb =
let c = { (default_context lb) with
loc = Loc.of_lexbuf lb;
antiquots = !Camlp4_config.antiquotations;
quotations = quotations }
in from_context c
let setup_loc lb loc =
let start_pos = Loc.start_pos loc in
lb.lex_abs_pos <- start_pos.pos_cnum;
lb.lex_curr_p <- start_pos
let from_string ?quotations loc str =
let lb = Lexing.from_string str in
setup_loc lb loc;
from_lexbuf ?quotations lb
let from_stream ?quotations loc strm =
let lb = Lexing.from_function (lexing_store strm) in
setup_loc lb loc;
from_lexbuf ?quotations lb
let mk () loc strm =
from_stream ~quotations:!Camlp4_config.quotations loc strm
end
}

307
camlp4/Camlp4/Struct/Loc.ml
View File

@ -1,307 +0,0 @@
(****************************************************************************)
(* *)
(* OCaml *)
(* *)
(* INRIA Rocquencourt *)
(* *)
(* Copyright 2006 Institut National de Recherche en Informatique et *)
(* en Automatique. All rights reserved. This file is distributed under *)
(* the terms of the GNU Library General Public License, with the special *)
(* exception on linking described in LICENSE at the top of the OCaml *)
(* source tree. *)
(* *)
(****************************************************************************)
(* Authors:
* - Daniel de Rauglaudre: initial version
* - Nicolas Pouillard: refactoring
*)
(* camlp4r *)
open Format;
(* FIXME
Study these 2 others implementations which change the ghost
handling:
type pos = ... the same ...
1/
type loc = {
file_name : string;
start : pos;
stop : pos
};
type t =
[ Nowhere
| Ghost of loc (* the closest non ghost loc *)
| Concrete of loc ];
2/
type loc = {
file_name : string;
start : pos;
stop : pos
};
type t = option loc;
3/
type t = {
file_name : option string;
start : pos;
stop : pos
};
*)
type pos = {
line : int;
bol : int;
off : int
};
type t = {
file_name : string;
start : pos;
stop : pos;
ghost : bool
};
(* Debug section *)
value dump_sel f x =
let s =
match x with
[ `start -> "`start"
| `stop -> "`stop"
| `both -> "`both"
| _ -> "<not-printable>" ]
in pp_print_string f s;
value dump_pos f x =
fprintf f "@[<hov 2>{ line = %d ;@ bol = %d ;@ off = %d } : pos@]"
x.line x.bol x.off;
value dump_long f x =
fprintf f
"@[<hov 2>{ file_name = %s ;@ start = %a (%d-%d);@ stop = %a (%d);@ ghost = %b@ } : Loc.t@]"
x.file_name dump_pos x.start (x.start.off - x.start.bol)
(x.stop.off - x.start.bol) dump_pos x.stop
(x.stop.off - x.stop.bol) x.ghost;
value dump f x =
fprintf f "[%S: %d:%d-%d %d:%d%t]"
x.file_name x.start.line (x.start.off - x.start.bol)
(x.stop.off - x.start.bol) x.stop.line (x.stop.off - x.stop.bol)
(fun o -> if x.ghost then fprintf o " (ghost)" else ());
value start_pos = { line = 1 ; bol = 0 ; off = 0 };
value ghost =
{ file_name = "ghost-location";
start = start_pos;
stop = start_pos;
ghost = True };
value mk file_name =
debug loc "mk %s@\n" file_name in
{ file_name = file_name;
start = start_pos;
stop = start_pos;
ghost = False };
value of_tuple (file_name, start_line, start_bol, start_off,
stop_line, stop_bol, stop_off, ghost) =
{ file_name = file_name;
start = { line = start_line ; bol = start_bol ; off = start_off };
stop = { line = stop_line ; bol = stop_bol ; off = stop_off };
ghost = ghost };
value to_tuple
{ file_name = file_name;
start = { line = start_line ; bol = start_bol ; off = start_off };
stop = { line = stop_line ; bol = stop_bol ; off = stop_off };
ghost = ghost } =
(file_name, start_line, start_bol, start_off,
stop_line, stop_bol, stop_off, ghost);
value pos_of_lexing_position p =
let pos =
{ line = p.Lexing.pos_lnum ;
bol = p.Lexing.pos_bol ;
off = p.Lexing.pos_cnum } in
debug loc "pos_of_lexing_position: %a@\n" dump_pos pos in
pos;
value pos_to_lexing_position p file_name =
(* debug loc "pos_to_lexing_position: %a@\n" dump_pos p in *)
{ Lexing.
pos_fname = file_name;
pos_lnum = p.line ;
pos_bol = p.bol ;
pos_cnum = p.off };
value better_file_name a b =
match (a, b) with
[ ("", "") -> a
| ("", x) -> x
| (x, "") -> x
| ("-", x) -> x
| (x, "-") -> x
| (x, _) -> x ];
value of_lexbuf lb =
let start = Lexing.lexeme_start_p lb
and stop = Lexing.lexeme_end_p lb in
let loc =
{ file_name = better_file_name start.Lexing.pos_fname stop.Lexing.pos_fname;
start = pos_of_lexing_position start;
stop = pos_of_lexing_position stop;
ghost = False } in
debug loc "of_lexbuf: %a@\n" dump loc in
loc;
value of_lexing_position pos =
let loc =
{ file_name = pos.Lexing.pos_fname;
start = pos_of_lexing_position pos;
stop = pos_of_lexing_position pos;
ghost = False } in
debug loc "of_lexing_position: %a@\n" dump loc in
loc;
value to_ocaml_location x =
debug loc "to_ocaml_location: %a@\n" dump x in
{ Camlp4_import.Location.
loc_start = pos_to_lexing_position x.start x.file_name;
loc_end = pos_to_lexing_position x.stop x.file_name;
loc_ghost = x.ghost };
value of_ocaml_location { Camlp4_import.Location.loc_start = a; loc_end = b; loc_ghost = g } =
let res =
{ file_name = better_file_name a.Lexing.pos_fname b.Lexing.pos_fname;
start = pos_of_lexing_position a;
stop = pos_of_lexing_position b;
ghost = g } in
debug loc "of_ocaml_location: %a@\n" dump res in
res;
value start_pos x = pos_to_lexing_position x.start x.file_name;
value stop_pos x = pos_to_lexing_position x.stop x.file_name;
value merge a b =
if a == b then
debug loc "trivial merge@\n" in
a
else
let r =
match (a.ghost, b.ghost) with
[ (False, False) ->
(* FIXME if a.file_name <> b.file_name then
raise (Invalid_argument
(sprintf "Loc.merge: Filenames must be equal: %s <> %s"
a.file_name b.file_name)) *)
(* else *)
{ (a) with stop = b.stop }
| (True, True) -> { (a) with stop = b.stop }
| (True, _) -> { (a) with stop = b.stop }
| (_, True) -> { (b) with start = a.start } ]
in debug loc "@[<hov 6>merge %a@ %a@ %a@]@\n" dump a dump b dump r in r;
value join x = { (x) with stop = x.start };
value map f start_stop_both x =
match start_stop_both with
[ `start -> { (x) with start = f x.start }
| `stop -> { (x) with stop = f x.stop }
| `both -> { (x) with start = f x.start; stop = f x.stop } ];
value move_pos chars x = { (x) with off = x.off + chars };
value move s chars x =
debug loc "move %a %d %a@\n" dump_sel s chars dump x in
map (move_pos chars) s x;
value move_line lines x =
debug loc "move_line %d %a@\n" lines dump x in
let move_line_pos x =
{ (x) with line = x.line + lines ; bol = x.off }
in map move_line_pos `both x;
value shift width x =
{ (x) with start = x.stop ; stop = move_pos width x.stop };
value file_name x = x.file_name;
value start_line x = x.start.line;
value stop_line x = x.stop.line;
value start_bol x = x.start.bol;
value stop_bol x = x.stop.bol;
value start_off x = x.start.off;
value stop_off x = x.stop.off;
value is_ghost x = x.ghost;
value set_file_name s x =
debug loc "set_file_name: %a@\n" dump x in
{ (x) with file_name = s };
value ghostify x =
debug loc "ghostify: %a@\n" dump x in
{ (x) with ghost = True };
value make_absolute x =
debug loc "make_absolute: %a@\n" dump x in
let pwd = Sys.getcwd () in
if Filename.is_relative x.file_name then
{ (x) with file_name = Filename.concat pwd x.file_name }
else x;
value strictly_before x y =
let b = x.stop.off < y.start.off && x.file_name = y.file_name in
debug loc "%a [strictly_before] %a => %b@\n" dump x dump y b in
b;
value to_string x = do {
let (a, b) = (x.start, x.stop) in
let res = sprintf "File \"%s\", line %d, characters %d-%d"
x.file_name a.line (a.off - a.bol) (b.off - a.bol) in
if x.start.line <> x.stop.line then
sprintf "%s (end at line %d, character %d)"
res x.stop.line (b.off - b.bol)
else res
};
value print out x = pp_print_string out (to_string x);
value check x msg =
if ((start_line x) > (stop_line x) ||
(start_bol x) > (stop_bol x) ||
(start_off x) > (stop_off x) ||
(start_line x) < 0 || (stop_line x) < 0 ||
(start_bol x) < 0 || (stop_bol x) < 0 ||
(start_off x) < 0 || (stop_off x) < 0)
(* Here, we don't check
(start_off x) < (start_bol x) || (stop_off x) < (start_bol x)
since the lexer is called on antiquotations, with off=0, but line and bolpos
have "correct" values *)
then do {
eprintf "*** Warning: (%s) strange positions ***\n%a@\n" msg print x;
False
}
else True;
exception Exc_located of t and exn;
ErrorHandler.register
(fun ppf ->
fun [ Exc_located loc exn ->
fprintf ppf "%a:@\n%a" print loc ErrorHandler.print exn
| exn -> raise exn ]);
value name = ref "_loc";
value raise loc exc =
match exc with
[ Exc_located _ _ -> raise exc
| _ -> raise (Exc_located loc exc) ]
;

19
camlp4/Camlp4/Struct/Loc.mli
View File

@ -1,19 +0,0 @@
(****************************************************************************)
(* *)
(* OCaml *)
(* *)
(* INRIA Rocquencourt *)
(* *)
(* Copyright 2006 Institut National de Recherche en Informatique et *)
(* en Automatique. All rights reserved. This file is distributed under *)
(* the terms of the GNU Library General Public License, with the special *)
(* exception on linking described in LICENSE at the top of the OCaml *)
(* source tree. *)
(* *)
(****************************************************************************)
(* Authors:
* - Daniel de Rauglaudre: initial version
* - Nicolas Pouillard: refactoring
*)
include Sig.Loc;

167
camlp4/Camlp4/Struct/Quotation.ml
View File

@ -1,167 +0,0 @@
(* camlp4r *)
(****************************************************************************)
(* *)
(* OCaml *)
(* *)
(* INRIA Rocquencourt *)
(* *)
(* Copyright 2002-2006 Institut National de Recherche en Informatique et *)
(* en Automatique. All rights reserved. This file is distributed under *)
(* the terms of the GNU Library General Public License, with the special *)
(* exception on linking described in LICENSE at the top of the OCaml *)
(* source tree. *)
(* *)
(****************************************************************************)
(* Authors:
* - Daniel de Rauglaudre: initial version
* - Nicolas Pouillard: refactoring
*)
module Make (Ast : Sig.Camlp4Ast)
: Sig.Quotation with module Ast = Ast
= struct
module Ast = Ast;
module DynAst = DynAst.Make Ast;
module Loc = Ast.Loc;
open Format;
open Sig;
type expand_fun 'a = Loc.t -> option string -> string -> 'a;
module Exp_key = DynAst.Pack(struct
type t 'a = unit;
end);
module Exp_fun = DynAst.Pack(struct
type t 'a = expand_fun 'a;
end);
value expanders_table =
(ref [] : ref (list ((string * Exp_key.pack) * Exp_fun.pack)));
value default = ref "";
value translate = ref (fun x -> x);
value expander_name name =
match translate.val name with
[ "" -> default.val
| name -> name ];
value find name tag =
let key = (expander_name name, Exp_key.pack tag ()) in
Exp_fun.unpack tag (List.assoc key expanders_table.val);
value add name tag f =
let elt = ((name, Exp_key.pack tag ()), Exp_fun.pack tag f) in
expanders_table.val := [elt :: expanders_table.val];
value dump_file = ref None;
module Error = struct
type error =
[ Finding
| Expanding
| ParsingResult of Loc.t and string
| Locating ];
type t = (string * string * error * exn);
exception E of t;
value print ppf (name, position, ctx, exn) =
let name = if name = "" then default.val else name in
let pp x = fprintf ppf "@?@[<2>While %s %S in a position of %S:" x name position in
let () =
match ctx with
[ Finding -> begin
pp "finding quotation";
if expanders_table.val = [] then
fprintf ppf "@ There is no quotation expander available."
else
begin
fprintf ppf "@ @[<hv2>Available quotation expanders are:@\n";
List.iter begin fun ((s,t),_) ->
fprintf ppf "@[<2>%s@ (in@ a@ position@ of %a)@]@ "
s Exp_key.print_tag t
end expanders_table.val;
fprintf ppf "@]"
end
end
| Expanding -> pp "expanding quotation"
| Locating -> pp "parsing"
| ParsingResult loc str ->
let () = pp "parsing result of quotation" in
match dump_file.val with
[ Some dump_file ->
let () = fprintf ppf " dumping result...\n" in
try
let oc = open_out_bin dump_file in
begin
output_string oc str;
output_string oc "\n";
flush oc;
close_out oc;
fprintf ppf "%a:" Loc.print (Loc.set_file_name dump_file loc);
end
with _ ->
fprintf ppf
"Error while dumping result in file %S; dump aborted"
dump_file
| None ->
fprintf ppf
"\n(consider setting variable Quotation.dump_file, or using the -QD option)"
]
]
in fprintf ppf "@\n%a@]@." ErrorHandler.print exn;
value to_string x =
let b = Buffer.create 50 in
let () = bprintf b "%a" print x in Buffer.contents b;
end;
let module M = ErrorHandler.Register Error in ();
open Error;
value expand_quotation loc expander pos_tag quot =
debug quot "expand_quotation: name: %s, str: %S@." quot.q_name quot.q_contents in
let loc_name_opt = if quot.q_loc = "" then None else Some quot.q_loc in
try expander loc loc_name_opt quot.q_contents with
[ Loc.Exc_located _ (Error.E _) as exc ->
raise exc
| Loc.Exc_located iloc exc ->
let exc1 = Error.E (quot.q_name, pos_tag, Expanding, exc) in
raise (Loc.Exc_located iloc exc1)
| exc ->
let exc1 = Error.E (quot.q_name, pos_tag, Expanding, exc) in
raise (Loc.Exc_located loc exc1) ];
value parse_quotation_result parse loc quot pos_tag str =
try parse loc str with
[ Loc.Exc_located iloc (Error.E (n, pos_tag, Expanding, exc)) ->
let ctx = ParsingResult iloc quot.q_contents in
let exc1 = Error.E (n, pos_tag, ctx, exc) in
raise (Loc.Exc_located iloc exc1)
| Loc.Exc_located iloc (Error.E _ as exc) ->
raise (Loc.Exc_located iloc exc)
| Loc.Exc_located iloc exc ->
let ctx = ParsingResult iloc quot.q_contents in
let exc1 = Error.E (quot.q_name, pos_tag, ctx, exc) in
raise (Loc.Exc_located iloc exc1) ];
value expand loc quotation tag =
let pos_tag = DynAst.string_of_tag tag in
let name = quotation.q_name in
debug quot "handle_quotation: name: %s, str: %S@." name quotation.q_contents in
let expander =
try find name tag
with
[ Loc.Exc_located _ (Error.E _) as exc -> raise exc
| Loc.Exc_located qloc exc ->
raise (Loc.Exc_located qloc (Error.E (name, pos_tag, Finding, exc)))
| exc ->
raise (Loc.Exc_located loc (Error.E (name, pos_tag, Finding, exc))) ]
in
let loc = Loc.join (Loc.move `start quotation.q_shift loc) in
expand_quotation loc expander pos_tag quotation;
end;

244
camlp4/Camlp4/Struct/Token.ml
View File

@ -1,244 +0,0 @@
(****************************************************************************)
(* *)
(* OCaml *)
(* *)
(* INRIA Rocquencourt *)
(* *)
(* Copyright 2006 Institut National de Recherche en Informatique et *)
(* en Automatique. All rights reserved. This file is distributed under *)
(* the terms of the GNU Library General Public License, with the special *)
(* exception on linking described in LICENSE at the top of the OCaml *)
(* source tree. *)
(* *)
(****************************************************************************)
(* Authors:
* - Nicolas Pouillard: initial version
*)
open Format;
module Make (Loc : Sig.Loc)
: Sig.Camlp4Token with module Loc = Loc
= struct
module Loc = Loc;
open Sig;
type t = camlp4_token;
type token = t;
value to_string =
fun
[ KEYWORD s -> sprintf "KEYWORD %S" s
| SYMBOL s -> sprintf "SYMBOL %S" s
| LIDENT s -> sprintf "LIDENT %S" s
| UIDENT s -> sprintf "UIDENT %S" s
| INT _ s -> sprintf "INT %s" s
| INT32 _ s -> sprintf "INT32 %sd" s
| INT64 _ s -> sprintf "INT64 %sd" s
| NATIVEINT _ s-> sprintf "NATIVEINT %sd" s
| FLOAT _ s -> sprintf "FLOAT %s" s
| CHAR _ s -> sprintf "CHAR '%s'" s
| STRING _ s -> sprintf "STRING \"%s\"" s
(* here it's not %S since the string is already escaped *)
| LABEL s -> sprintf "LABEL %S" s
| OPTLABEL s -> sprintf "OPTLABEL %S" s
| ANTIQUOT n s -> sprintf "ANTIQUOT %s: %S" n s
| QUOTATION x -> sprintf "QUOTATION { q_name=%S; q_loc=%S; q_shift=%d; q_contents=%S }"
x.q_name x.q_loc x.q_shift x.q_contents
| COMMENT s -> sprintf "COMMENT %S" s
| BLANKS s -> sprintf "BLANKS %S" s
| NEWLINE -> sprintf "NEWLINE"
| EOI -> sprintf "EOI"
| ESCAPED_IDENT s -> sprintf "ESCAPED_IDENT %S" s
| LINE_DIRECTIVE i None -> sprintf "LINE_DIRECTIVE %d" i
| LINE_DIRECTIVE i (Some s) -> sprintf "LINE_DIRECTIVE %d %S" i s ];
value print ppf x = pp_print_string ppf (to_string x);
value match_keyword kwd =
fun
[ KEYWORD kwd' when kwd = kwd' -> True
| _ -> False ];
value extract_string =
fun
[ KEYWORD s | SYMBOL s | LIDENT s | UIDENT s | INT _ s | INT32 _ s |
INT64 _ s | NATIVEINT _ s | FLOAT _ s | CHAR _ s | STRING _ s |
LABEL s | OPTLABEL s | COMMENT s | BLANKS s | ESCAPED_IDENT s -> s
| tok ->
invalid_arg ("Cannot extract a string from this token: "^
to_string tok) ];
module Error = struct
type t =
[ Illegal_token of string
| Keyword_as_label of string
| Illegal_token_pattern of string and string
| Illegal_constructor of string ];
exception E of t;
value print ppf =
fun
[ Illegal_token s ->
fprintf ppf "Illegal token (%s)" s
| Keyword_as_label kwd ->
fprintf ppf "`%s' is a keyword, it cannot be used as label name" kwd
| Illegal_token_pattern p_con p_prm ->
fprintf ppf "Illegal token pattern: %s %S" p_con p_prm
| Illegal_constructor con ->
fprintf ppf "Illegal constructor %S" con ];
value to_string x =
let b = Buffer.create 50 in
let () = bprintf b "%a" print x in Buffer.contents b;
end;
let module M = ErrorHandler.Register Error in ();
module Filter = struct
type token_filter = stream_filter t Loc.t;
type t =
{ is_kwd : string -> bool;
filter : mutable token_filter };
value err error loc =
raise (Loc.Exc_located loc (Error.E error));
value keyword_conversion tok is_kwd =
match tok with
[ SYMBOL s | LIDENT s | UIDENT s when is_kwd s -> KEYWORD s
| ESCAPED_IDENT s -> LIDENT s
| _ -> tok ];
value check_keyword_as_label tok loc is_kwd =
let s =
match tok with
[ LABEL s -> s
| OPTLABEL s -> s
| _ -> "" ]
in if s <> "" && is_kwd s then err (Error.Keyword_as_label s) loc else ();
value check_unknown_keywords tok loc =
match tok with
[ SYMBOL s -> err (Error.Illegal_token s) loc
| _ -> () ];
value error_no_respect_rules p_con p_prm =
raise (Error.E (Error.Illegal_token_pattern p_con p_prm));
value check_keyword _ = True;
(* FIXME let lb = Lexing.from_string s in
let next () = token default_context lb in
try
match next () with
[ SYMBOL _ | UIDENT _ | LIDENT _ -> (next () = EOI)
| _ -> False ]
with [ Stream.Error _ -> False ]; *)
value error_on_unknown_keywords = ref False;
value rec ignore_layout =
parser
[ [: `(COMMENT _ | BLANKS _ | NEWLINE | LINE_DIRECTIVE _ _, _); s :] ->
ignore_layout s
| [: ` x; s :] -> [: ` x; ignore_layout s :]
| [: :] -> [: :] ];
value mk is_kwd =
{ is_kwd = is_kwd;
filter = ignore_layout };
value filter x =
let f tok loc = do {
let tok = keyword_conversion tok x.is_kwd;
check_keyword_as_label tok loc x.is_kwd;
if error_on_unknown_keywords.val
then check_unknown_keywords tok loc else ();
debug token "@[<hov 2>Lexer before filter:@ %a@ at@ %a@]@."
print tok Loc.dump loc in
(tok, loc)
} in
let rec filter =
parser
[ [: `(tok, loc); s :] -> [: ` f tok loc; filter s :]
| [: :] -> [: :] ]
in
let rec tracer = (* FIXME add a debug block construct *)
parser
[ [: `((_tok, _loc) as x); xs :] ->
debug token "@[<hov 2>Lexer after filter:@ %a@ at@ %a@]@."
print _tok Loc.dump _loc in
[: ` x; tracer xs :]
| [: :] -> [: :] ]
in fun strm -> tracer (x.filter (filter strm));
value define_filter x f = x.filter := f x.filter;
value keyword_added _ _ _ = ();
value keyword_removed _ _ = ();
end;
end;
(* Char and string tokens to real chars and string *)
module Eval = struct
value valch x = Char.code x - Char.code '0';
value valch_hex x =
let d = Char.code x in
if d >= 97 then d - 87
else if d >= 65 then d - 55
else d - 48;
value rec skip_indent = parser
[ [: `' ' | '\t'; s :] -> skip_indent s
| [: :] -> () ];
value skip_opt_linefeed = parser
[ [: `'\010' :] -> ()
| [: :] -> () ];
value chr c =
if c < 0 || c > 255 then failwith "invalid char token" else Char.chr c;
value rec backslash = parser
[ [: `'\010' :] -> '\010'
| [: `'\013' :] -> '\013'
| [: `'n' :] -> '\n'
| [: `'r' :] -> '\r'
| [: `'t' :] -> '\t'
| [: `'b' :] -> '\b'
| [: `'\\' :] -> '\\'
| [: `'"' :] -> '"'
| [: `'\'' :] -> '\''
| [: `' ' :] -> ' '
| [: `('0'..'9' as c1); `('0'..'9' as c2); `('0'..'9' as c3) :] ->
chr (100 * (valch c1) + 10 * (valch c2) + (valch c3))
| [: `'x'; `('0'..'9' | 'a'..'f' | 'A'..'F' as c1) ;
`('0'..'9' | 'a'..'f' | 'A'..'F' as c2) :] ->
chr (16 * (valch_hex c1) + (valch_hex c2)) ];
value rec backslash_in_string strict store = parser
[ [: `'\010'; s :] -> skip_indent s
| [: `'\013'; s :] -> do { skip_opt_linefeed s; skip_indent s }
| [: x = backslash :] -> store x
| [: `c when not strict :] -> do { store '\\'; store c }
| [: :] -> failwith "invalid string token" ];
value char s =
if String.length s = 1 then s.[0]
else if String.length s = 0 then failwith "invalid char token"
else match Stream.of_string s with parser
[ [: `'\\'; x = backslash :] -> x
| [: :] -> failwith "invalid char token" ];
value string ?strict s =
let buf = Buffer.create 23 in
let store = Buffer.add_char buf in
let rec parse = parser
[ [: `'\\'; _ = backslash_in_string (strict <> None) store; s :] -> parse s
| [: `c; s :] -> do { store c; parse s }
| [: :] -> Buffer.contents buf ]
in parse (Stream.of_string s);
end;

35
camlp4/Camlp4/Struct/Token.mli
View File

@ -1,35 +0,0 @@
(****************************************************************************)
(* *)
(* OCaml *)
(* *)
(* INRIA Rocquencourt *)
(* *)
(* Copyright 2006 Institut National de Recherche en Informatique et *)
(* en Automatique. All rights reserved. This file is distributed under *)
(* the terms of the GNU Library General Public License, with the special *)
(* exception on linking described in LICENSE at the top of the OCaml *)
(* source tree. *)
(* *)
(****************************************************************************)
(* Authors:
* - Daniel de Rauglaudre: initial version
* - Nicolas Pouillard: refactoring
*)
module Make (Loc : Sig.Loc) : Sig.Camlp4Token with module Loc = Loc;
module Eval : sig
value char : string -> char;
(** Convert a char token, where the escape sequences (backslashes)
remain to be interpreted; raise [Failure] if an
incorrect backslash sequence is found; [Token.Eval.char (Char.escaped c)]
returns [c] *)
value string : ?strict:unit -> string -> string;
(** [Taken.Eval.string strict s]
Convert a string token, where the escape sequences (backslashes)
remain to be interpreted; raise [Failure] if [strict] and an
incorrect backslash sequence is found;
[Token.Eval.string strict (String.escaped s)] returns [s] *)
end;

325
camlp4/Camlp4Bin.ml
View File

@ -1,325 +0,0 @@
(* camlp4r *)
(****************************************************************************)
(* *)
(* OCaml *)
(* *)
(* INRIA Rocquencourt *)
(* *)
(* Copyright 2006 Institut National de Recherche en Informatique et *)
(* en Automatique. All rights reserved. This file is distributed under *)
(* the terms of the GNU Library General Public License, with the special *)
(* exception on linking described in LICENSE at the top of the OCaml *)
(* source tree. *)
(* *)
(****************************************************************************)
(* Authors:
* - Daniel de Rauglaudre: initial version
* - Nicolas Pouillard: refactoring
*)
open Camlp4;
open PreCast.Syntax;
open PreCast;
open Format;
module CleanAst = Camlp4.Struct.CleanAst.Make Ast;
module SSet = Set.Make String;
value pa_r = "Camlp4OCamlRevisedParser";
value pa_rr = "Camlp4OCamlReloadedParser";
value pa_o = "Camlp4OCamlParser";
value pa_rp = "Camlp4OCamlRevisedParserParser";
value pa_op = "Camlp4OCamlParserParser";
value pa_g = "Camlp4GrammarParser";
value pa_m = "Camlp4MacroParser";
value pa_qb = "Camlp4QuotationCommon";
value pa_q = "Camlp4QuotationExpander";
value pa_rq = "Camlp4OCamlRevisedQuotationExpander";
value pa_oq = "Camlp4OCamlOriginalQuotationExpander";
value pa_l = "Camlp4ListComprehension";
open Register;
value dyn_loader = ref (fun []);
value rcall_callback = ref (fun () -> ());
value loaded_modules = ref SSet.empty;
value add_to_loaded_modules name =
loaded_modules.val := SSet.add name loaded_modules.val;
value (objext,libext) =
if DynLoader.is_native then (".cmxs",".cmxs")
else (".cmo",".cma");
value rewrite_and_load n x =
let dyn_loader = dyn_loader.val () in
let find_in_path = DynLoader.find_in_path dyn_loader in
let real_load name = do {
add_to_loaded_modules name;
DynLoader.load dyn_loader name
} in
let load = List.iter begin fun n ->
if SSet.mem n loaded_modules.val || List.mem n Register.loaded_modules.val then ()
else begin
add_to_loaded_modules n;
DynLoader.load dyn_loader (n ^ objext);
end
end in
do {
match (n, String.lowercase x) with
[ ("Parsers"|"", "pa_r.cmo" | "r" | "ocamlr" | "ocamlrevised" | "camlp4ocamlrevisedparser.cmo") -> load [pa_r]
| ("Parsers"|"", "rr" | "reloaded" | "ocamlreloaded" | "camlp4ocamlreloadedparser.cmo") -> load [pa_rr]
| ("Parsers"|"", "pa_o.cmo" | "o" | "ocaml" | "camlp4ocamlparser.cmo") -> load [pa_r; pa_o]
| ("Parsers"|"", "pa_rp.cmo" | "rp" | "rparser" | "camlp4ocamlrevisedparserparser.cmo") -> load [pa_r; pa_rp]
| ("Parsers"|"", "pa_op.cmo" | "op" | "parser" | "camlp4ocamlparserparser.cmo") -> load [pa_r; pa_o; pa_rp; pa_op]
| ("Parsers"|"", "pa_extend.cmo" | "pa_extend_m.cmo" | "g" | "grammar" | "camlp4grammarparser.cmo") -> load [pa_g]
| ("Parsers"|"", "pa_macro.cmo" | "m" | "macro" | "camlp4macroparser.cmo") -> load [pa_m]
| ("Parsers"|"", "q" | "camlp4quotationexpander.cmo") -> load [pa_qb; pa_q]
| ("Parsers"|"", "q_mlast.cmo" | "rq" | "camlp4ocamlrevisedquotationexpander.cmo") -> load [pa_qb; pa_rq]
| ("Parsers"|"", "oq" | "camlp4ocamloriginalquotationexpander.cmo") -> load [pa_r; pa_o; pa_qb; pa_oq]
| ("Parsers"|"", "rf") -> load [pa_r; pa_rp; pa_qb; pa_q; pa_g; pa_l; pa_m]
| ("Parsers"|"", "of") -> load [pa_r; pa_o; pa_rp; pa_op; pa_qb; pa_q; pa_g; pa_l; pa_m]
| ("Parsers"|"", "comp" | "camlp4listcomprehension.cmo") -> load [pa_l]
| ("Filters"|"", "lift" | "camlp4astlifter.cmo") -> load ["Camlp4AstLifter"]
| ("Filters"|"", "exn" | "camlp4exceptiontracer.cmo") -> load ["Camlp4ExceptionTracer"]
| ("Filters"|"", "prof" | "camlp4profiler.cmo") -> load ["Camlp4Profiler"]
(* map is now an alias of fold since fold handles map too *)
| ("Filters"|"", "map" | "camlp4mapgenerator.cmo") -> load ["Camlp4FoldGenerator"]
| ("Filters"|"", "fold" | "camlp4foldgenerator.cmo") -> load ["Camlp4FoldGenerator"]
| ("Filters"|"", "meta" | "camlp4metagenerator.cmo") -> load ["Camlp4MetaGenerator"]
| ("Filters"|"", "trash" | "camlp4trashremover.cmo") -> load ["Camlp4TrashRemover"]
| ("Filters"|"", "striploc" | "camlp4locationstripper.cmo") -> load ["Camlp4LocationStripper"]
| ("Printers"|"", "pr_r.cmo" | "r" | "ocamlr" | "camlp4ocamlrevisedprinter.cmo") ->
Register.enable_ocamlr_printer ()
| ("Printers"|"", "pr_o.cmo" | "o" | "ocaml" | "camlp4ocamlprinter.cmo") ->
Register.enable_ocaml_printer ()
| ("Printers"|"", "pr_dump.cmo" | "p" | "dumpocaml" | "camlp4ocamlastdumper.cmo") ->
Register.enable_dump_ocaml_ast_printer ()
| ("Printers"|"", "d" | "dumpcamlp4" | "camlp4astdumper.cmo") ->
Register.enable_dump_camlp4_ast_printer ()
| ("Printers"|"", "a" | "auto" | "camlp4autoprinter.cmo") ->
load ["Camlp4AutoPrinter"]
| _ ->
let y = "Camlp4"^n^"/"^x^objext in
real_load (try find_in_path y with [ Not_found -> x ]) ];
rcall_callback.val ();
};
value print_warning = eprintf "%a:\n%s@." Loc.print;
value rec parse_file dyn_loader name pa getdir =
let directive_handler = Some (fun ast ->
match getdir ast with
[ Some x ->
match x with
[ (_, "load", s) -> do { rewrite_and_load "" s; None }
| (_, "directory", s) -> do { DynLoader.include_dir dyn_loader s; None }
| (_, "use", s) -> Some (parse_file dyn_loader s pa getdir)
| (_, "default_quotation", s) -> do { Quotation.default.val := s; None }
| (loc, _, _) -> Loc.raise loc (Stream.Error "bad directive") ]
| None -> None ]) in
let loc = Loc.mk name
in do {
current_warning.val := print_warning;
let ic = if name = "-" then stdin else open_in_bin name;
let cs = Stream.of_channel ic;
let clear () = if name = "-" then () else close_in ic;
let phr =
try pa ?directive_handler loc cs
with x -> do { clear (); raise x };
clear ();
phr
};
value output_file = ref None;
value process dyn_loader name pa pr clean fold_filters getdir =
let ast = parse_file dyn_loader name pa getdir in
let ast = fold_filters (fun t filter -> filter t) ast in
let ast = clean ast in
pr ?input_file:(Some name) ?output_file:output_file.val ast;
value gind =
fun
[ <:sig_item@loc< # $n$ $str:s$ >> -> Some (loc, n, s)
| _ -> None ];
value gimd =
fun
[ <:str_item@loc< # $n$ $str:s$ >> -> Some (loc, n, s)
| _ -> None ];
value process_intf dyn_loader name =
process dyn_loader name CurrentParser.parse_interf CurrentPrinter.print_interf
(new CleanAst.clean_ast)#sig_item
AstFilters.fold_interf_filters gind;
value process_impl dyn_loader name =
process dyn_loader name CurrentParser.parse_implem CurrentPrinter.print_implem
(new CleanAst.clean_ast)#str_item
AstFilters.fold_implem_filters gimd;
value just_print_the_version () =
do { printf "%s@." Camlp4_config.version; exit 0 };
value print_version () =
do { eprintf "Camlp4 version %s@." Camlp4_config.version; exit 0 };
value print_stdlib () =
do { printf "%s@." Camlp4_config.camlp4_standard_library; exit 0 };
value usage ini_sl ext_sl =
do {
eprintf "\
Usage: camlp4 [load-options] [--] [other-options]\n\
Options:\n\
<file>.ml Parse this implementation file\n\
<file>.mli Parse this interface file\n\
<file>.%s Load this module inside the Camlp4 core@."
(if DynLoader.is_native then "cmxs " else "(cmo|cma)")
;
Options.print_usage_list ini_sl;
(* loop (ini_sl @ ext_sl) where rec loop =
fun
[ [(y, _, _) :: _] when y = "-help" -> ()
| [_ :: sl] -> loop sl
| [] -> eprintf " -help Display this list of options.@." ]; *)
if ext_sl <> [] then do {
eprintf "Options added by loaded object files:@.";
Options.print_usage_list ext_sl;
}
else ();
};
value warn_noassert () =
do {
eprintf "\
camlp4 warning: option -noassert is obsolete\n\
You should give the -noassert option to the ocaml compiler instead.@.";
};
type file_kind =
[ Intf of string
| Impl of string
| Str of string
| ModuleImpl of string
| IncludeDir of string ];
value search_stdlib = ref True;
value print_loaded_modules = ref False;
value (task, do_task) =
let t = ref None in
let task f x =
let () = Camlp4_config.current_input_file.val := x in
t.val := Some (if t.val = None then (fun _ -> f x)
else (fun usage -> usage ())) in
let do_task usage = match t.val with [ Some f -> f usage | None -> () ] in
(task, do_task);
value input_file x =
let dyn_loader = dyn_loader.val () in
do {
rcall_callback.val ();
match x with
[ Intf file_name -> task (process_intf dyn_loader) file_name
| Impl file_name -> task (process_impl dyn_loader) file_name
| Str s ->
begin
let (f, o) = Filename.open_temp_file "from_string" ".ml";
output_string o s;
close_out o;
task (process_impl dyn_loader) f;
at_exit (fun () -> Sys.remove f);
end
| ModuleImpl file_name -> rewrite_and_load "" file_name
| IncludeDir dir -> DynLoader.include_dir dyn_loader dir ];
rcall_callback.val ();
};
value initial_spec_list =
[("-I", Arg.String (fun x -> input_file (IncludeDir (Camlp4_import.Misc.expand_directory Camlp4_config.camlp4_standard_library x))),
"<directory> Add directory in search patch for object files.");
("-where", Arg.Unit print_stdlib,
"Print camlp4 library directory and exit.");
("-nolib", Arg.Clear search_stdlib,
"No automatic search for object files in library directory.");
("-intf", Arg.String (fun x -> input_file (Intf x)),
"<file> Parse <file> as an interface, whatever its extension.");
("-impl", Arg.String (fun x -> input_file (Impl x)),
"<file> Parse <file> as an implementation, whatever its extension.");
("-str", Arg.String (fun x -> input_file (Str x)),
"<string> Parse <string> as an implementation.");
("-unsafe", Arg.Set Camlp4_config.unsafe,
"Generate unsafe accesses to array and strings.");
("-noassert", Arg.Unit warn_noassert,
"Obsolete, do not use this option.");
("-verbose", Arg.Set Camlp4_config.verbose,
"More verbose in parsing errors.");
("-loc", Arg.Set_string Loc.name,
"<name> Name of the location variable (default: " ^ Loc.name.val ^ ").");
("-QD", Arg.String (fun x -> Quotation.dump_file.val := Some x),
"<file> Dump quotation expander result in case of syntax error.");
("-o", Arg.String (fun x -> output_file.val := Some x),
"<file> Output on <file> instead of standard output.");
("-v", Arg.Unit print_version,
"Print Camlp4 version and exit.");
("-version", Arg.Unit just_print_the_version,
"Print Camlp4 version number and exit.");
("-vnum", Arg.Unit just_print_the_version,
"Print Camlp4 version number and exit.");
("-no_quot", Arg.Clear Camlp4_config.quotations,
"Don't parse quotations, allowing to use, e.g. \"<:>\" as token.");
("-loaded-modules", Arg.Set print_loaded_modules, "Print the list of loaded modules.");
("-parser", Arg.String (rewrite_and_load "Parsers"),
"<name> Load the parser Camlp4Parsers/<name>.cm(o|a|xs)");
("-printer", Arg.String (rewrite_and_load "Printers"),
"<name> Load the printer Camlp4Printers/<name>.cm(o|a|xs)");
("-filter", Arg.String (rewrite_and_load "Filters"),
"<name> Load the filter Camlp4Filters/<name>.cm(o|a|xs)");
("-ignore", Arg.String ignore, "ignore the next argument");
("--", Arg.Unit ignore, "Deprecated, does nothing")
];
Options.init initial_spec_list;
value anon_fun name =
input_file
(if Filename.check_suffix name ".mli" then Intf name
else if Filename.check_suffix name ".ml" then Impl name
else if Filename.check_suffix name objext then ModuleImpl name
else if Filename.check_suffix name libext then ModuleImpl name
else raise (Arg.Bad ("don't know what to do with " ^ name)));
value main argv =
let usage () = do { usage initial_spec_list (Options.ext_spec_list ()); exit 0 } in
try do {
let dynloader = DynLoader.mk ~ocaml_stdlib:search_stdlib.val
~camlp4_stdlib:search_stdlib.val ();
dyn_loader.val := fun () -> dynloader;
let call_callback () =
Register.iter_and_take_callbacks
(fun (name, module_callback) ->
let () = add_to_loaded_modules name in
module_callback ());
call_callback ();
rcall_callback.val := call_callback;
match Options.parse anon_fun argv with
[ [] -> ()
| ["-help"|"--help"|"-h"|"-?" :: _] -> usage ()
| [s :: _] ->
do { eprintf "%s: unknown or misused option\n" s;
eprintf "Use option -help for usage@.";
exit 2 } ];
do_task usage;
call_callback ();
if print_loaded_modules.val then do {
SSet.iter (eprintf "%s@.") loaded_modules.val;
} else ()
}
with
[ Arg.Bad s -> do { eprintf "Error: %s\n" s;
eprintf "Use option -help for usage@.";
exit 2 }
| Arg.Help _ -> usage ()
| exc -> do { eprintf "@[<v0>%a@]@." ErrorHandler.print exc; exit 2 } ];
main Sys.argv;

44
camlp4/Camlp4Filters/Camlp4AstLifter.ml
View File

@ -1,44 +0,0 @@
(* camlp4r *)
(****************************************************************************)
(* *)
(* OCaml *)
(* *)
(* INRIA Rocquencourt *)
(* *)
(* Copyright 2006 Institut National de Recherche en Informatique et *)
(* en Automatique. All rights reserved. This file is distributed under *)
(* the terms of the GNU Library General Public License, with the special *)
(* exception on linking described in LICENSE at the top of the OCaml *)
(* source tree. *)
(* *)
(****************************************************************************)
(* Authors:
* - Nicolas Pouillard: initial version
*)
open Camlp4;
module Id = struct
value name = "Camlp4AstLifter";
value version = Sys.ocaml_version;
end;
module Make (AstFilters : Camlp4.Sig.AstFilters) = struct
open AstFilters;
module MetaLoc = struct
module Ast = Ast;
value meta_loc_patt _loc _ = <:patt< loc >>;
value meta_loc_expr _loc _ = <:expr< loc >>;
end;
module MetaAst = Ast.Meta.Make MetaLoc;
register_str_item_filter (fun ast ->
let _loc = Ast.loc_of_str_item ast in
<:str_item< let loc = Loc.ghost in $exp:MetaAst.Expr.meta_str_item _loc ast$ >>);
end;
let module M = Camlp4.Register.AstFilter Id Make in ();

68
camlp4/Camlp4Filters/Camlp4ExceptionTracer.ml
View File

@ -1,68 +0,0 @@
(* camlp4r *)
(****************************************************************************)
(* *)
(* OCaml *)
(* *)
(* INRIA Rocquencourt *)
(* *)
(* Copyright 2006 Institut National de Recherche en Informatique et *)
(* en Automatique. All rights reserved. This file is distributed under *)
(* the terms of the GNU Library General Public License, with the special *)
(* exception on linking described in LICENSE at the top of the OCaml *)
(* source tree. *)
(* *)
(****************************************************************************)
(* Authors:
* - Nicolas Pouillard: initial version
*)
open Camlp4;
module Id = struct
value name = "Camlp4ExceptionTracer";
value version = Sys.ocaml_version;
end;
module Make (AstFilters : Camlp4.Sig.AstFilters) = struct
open AstFilters;
open Ast;
value add_debug_expr e =
(* let _loc = Loc.make_absolute (MLast.loc_of_expr e) in *)
let _loc = Ast.loc_of_expr e in
let msg = "camlp4-debug: exc: %s at " ^ Loc.to_string _loc ^ "@." in
<:expr<
try $e$
with
[ Stream.Failure | Exit as exc -> raise exc
| exc -> do {
if Debug.mode "exc" then
Format.eprintf $`str:msg$ (Printexc.to_string exc) else ();
raise exc
} ] >>;
value rec map_match_case =
fun
[ <:match_case@_loc< $m1$ | $m2$ >> ->
<:match_case< $map_match_case m1$ | $map_match_case m2$ >>
| <:match_case@_loc< $p$ when $w$ -> $e$ >> ->
<:match_case@_loc< $p$ when $w$ -> $add_debug_expr e$ >>
| m -> m ];
value filter = object
inherit Ast.map as super;
method expr = fun
[ <:expr@_loc< fun [ $m$ ] >> -> <:expr< fun [ $map_match_case m$ ] >>
| x -> super#expr x ];
method str_item = fun
[ <:str_item< module Debug = $_$ >> as st -> st
| st -> super#str_item st ];
end;
register_str_item_filter filter#str_item;
end;
let module M = Camlp4.Register.AstFilter Id Make in ();

628
camlp4/Camlp4Filters/Camlp4FoldGenerator.ml
View File

@ -1,628 +0,0 @@
(* camlp4r *)
(****************************************************************************)
(* *)
(* OCaml *)
(* *)
(* INRIA Rocquencourt *)
(* *)
(* Copyright 2006-2007 Institut National de Recherche en Informatique et *)
(* en Automatique. All rights reserved. This file is distributed under *)
(* the terms of the GNU Library General Public License, with the special *)
(* exception on linking described in LICENSE at the top of the OCaml *)
(* source tree. *)
(* *)
(****************************************************************************)
(* Authors:
* - Nicolas Pouillard: initial version
*)
open Camlp4;
module Id = struct
value name = "Camlp4FoldGenerator";
value version = Sys.ocaml_version;
end;
module Make (AstFilters : Camlp4.Sig.AstFilters) = struct
open AstFilters;
module StringMap = Map.Make String;
open Ast;
value _loc = Loc.ghost;
value sf = Printf.sprintf;
value xik i k =
let i =
if i < 0 then assert False
else if i = 0 then ""
else sf "_i%d" i
in
let k =
if k < 1 then assert False
else if k = 1 then ""
else sf "_k%d" k
in
sf "_x%s%s" i k;
value exik i k = <:expr< $lid:xik i k$ >>;
value pxik i k = <:patt< $lid:xik i k$ >>;
value elidk y k = <:expr< $lid:sf "%s_%d" y k$ >>;
value plidk y k = <:patt< $lid:sf "%s_%d" y k$ >>;
value xs s = "_x_" ^ s;
value xsk = sf "_x_%s_%d";
value exsk s k = <:expr< $lid:xsk s k$>>;
value rec apply_expr accu =
fun
[ [] -> accu
| [x :: xs] ->
let _loc = Ast.loc_of_expr x
in apply_expr <:expr< $accu$ $x$ >> xs ];
value rec apply_patt accu =
fun
[ [] -> accu
| [x :: xs] ->
let _loc = Ast.loc_of_patt x
in apply_patt <:patt< $accu$ $x$ >> xs ];
value rec apply_ctyp accu =
fun
[ [] -> accu
| [x :: xs] ->
let _loc = Ast.loc_of_ctyp x
in apply_ctyp <:ctyp< $accu$ $x$ >> xs ];
value opt_map f = fun [ Some x -> Some (f x) | None -> None ];
value list_init f n =
let rec self m =
if m = n then []
else [f m :: self (succ m)]
in self 0;
value rec lid_of_ident sep =
fun
[ <:ident< $lid:s$ >> | <:ident< $uid:s$ >> -> s
| <:ident< $i1$.$i2$ >> -> lid_of_ident sep i1 ^ sep ^ lid_of_ident sep i2
| _ -> assert False ];
type type_decl = (string * Ast.ident * list Ast.ctyp * Ast.ctyp * bool);
value builtin_types =
let tyMap = StringMap.empty in
let tyMap =
let abstr = ["string"; "int"; "float"; "int32"; "int64"; "nativeint"; "char"] in
List.fold_right
(fun name -> StringMap.add name (name, <:ident< $lid:name$ >>, [], <:ctyp<>>, False))
abstr tyMap
in
let tyMap =
let concr =
[("bool", <:ident<bool>>, [], <:ctyp< [ False | True ] >>, False);
("list", <:ident<list>>, [ <:ctyp< 'a >> ], <:ctyp< [ $uid:"[]"$ | $uid:"::"$ of 'a and list 'a ] >>, False);
("option", <:ident<option>>, [ <:ctyp< 'a >> ], <:ctyp< [ None | Some of 'a ] >>, False);
("ref", <:ident<ref>>, [ <:ctyp< 'a >> ], <:ctyp< { contents : 'a } >>, False)]
in
List.fold_right (fun ((name, _, _, _, _) as decl) -> StringMap.add name decl) concr tyMap
in
tyMap;
value used_builtins = ref StringMap.empty;
value store_if_builtin_type id =
if StringMap.mem id builtin_types then
used_builtins.val := StringMap.add id (StringMap.find id builtin_types) used_builtins.val
else ();
type mode = [ Fold | Map | Fold_map ];
value string_of_mode = fun [ Fold -> "fold" | Map -> "map" | Fold_map -> "fold_map" ];
module Gen (X :
sig
value size : int;
value mode : mode;
end) =
struct
value size = X.size;
value mode = X.mode;
value tuplify_expr f =
if size <= 0 then assert False
else if size = 1 then f 1
else
let rec loop k =
if k = 2 then f 2
else <:expr< $loop (k - 1)$, $f k$ >>
in <:expr< ($f 1$, $loop size$) >>;
value tuplify_patt f =
if size <= 0 then assert False
else if size = 1 then f 1
else
let rec loop k =
if k = 2 then f 2
else <:patt< $loop (k - 1)$, $f k$ >>
in <:patt< ($f 1$, $loop size$) >>;
value xiks i = tuplify_expr (exik i);
value tuplify_type typ =
if size <= 0 then assert False
else if size = 1 then typ
else
let rec loop k =
if k = 2 then typ
else <:ctyp< $loop (k - 1)$ * $typ$ >>
in <:ctyp< ($typ$ * $loop size$) >>;
value tuplify_tycon tycon = tuplify_type <:ctyp< $lid:tycon$ >>;
value rec patt_of_expr =
fun
[ <:expr<>> -> <:patt<>>
| <:expr< $id:i$ >> -> <:patt< $id:i$ >>
| <:expr< $e1$, $e2$ >> -> <:patt< $patt_of_expr e1$, $patt_of_expr e2$ >>
| <:expr< $tup:e$ >> -> <:patt< $tup:patt_of_expr e$ >>
| _ -> assert False ];
value bind p e1 e2 =
match mode with
[ Fold_map -> <:expr< let (o, $p$) = $e1$ in $e2$ >>
| Map -> <:expr< let $p$ = $e1$ in $e2$ >>
| Fold -> <:expr< let o = $e1$ in $e2$ >> ];
value return e =
match mode with
[ Fold_map -> <:expr< (o, $e$) >>
| Map -> e
| Fold -> <:expr<o>> ];
value rec opt_bind opt_patt e1 mk_e2 =
match e1 with
[ <:expr< $id:_$ >> | <:expr< $lid:_$#$_$ >> -> mk_e2 e1
| <:expr< let $p1$ = $e1$ in $e2$ >> ->
<:expr< let $p1$ = $e1$ in $opt_bind None e2 mk_e2$ >>
| _ ->
let e2 = mk_e2 <:expr<o>> in
match opt_patt with
[ Some patt -> bind patt e1 e2
| None -> <:expr< (fun o -> $e1$) $e2$ >> ] ];
(* ts = [t1; ...; tN] *)
value chain_tuple mkp mke expr_of_ty ts =
(* exiks = [<<(x_i0_k1, ..., x_i0_kM)>>; ...; <<(x_iN_k1, ..., x_iN_kM)>>] *)
let exiks = list_init (fun i -> tuplify_expr (exik i)) (List.length ts) in
(* exi1s, pxi1s = [<<x_i0_k1>>; ...; <<x_iN_k1>>] *)
let exi1s = list_init (fun i -> exik i 1) (List.length ts) in
let pxi1s = list_init (fun i -> pxik i 1) (List.length ts) in
let ps k = mkp (list_init (fun i -> pxik i k) (List.length ts)) in
let p = tuplify_patt ps in
let e1 = mke exi1s in
let es = List.map2 (fun x -> expr_of_ty (Some x)) exiks ts in
let e =
List.fold_right2 begin fun pxi1 e acc ->
bind pxi1 e acc
end pxi1s es (return e1)
in
<:match_case< $p$ -> $e$ >>;
value mk_tuple expr_of_ty t =
let mc =
chain_tuple
(fun ps -> <:patt< ($tup:Ast.paCom_of_list ps$) >>)
(fun es -> <:expr< ($tup:Ast.exCom_of_list es$) >>)
expr_of_ty (Ast.list_of_ctyp t [])
in <:expr< fun [ $mc$ ] >>;
value default_match_case =
let mk k = if k = 1 then <:patt< x >> else <:patt< _ >> in
match mode with
[ Fold_map -> <:match_case< $tuplify_patt mk$ -> (o, x) >>
| Fold -> <:match_case< _ -> o >>
| Map -> <:match_case< $tuplify_patt mk$ -> x >> ];
value default_expr = <:expr< fun [ $default_match_case$ ] >>;
value mkfuno e =
match e with
[ <:expr< $e$ o >> -> e
| _ -> <:expr< fun o -> $e$ >> ];
value is_unknown t =
let rec loop t =
match t with
[ <:ctyp< $lid:_$ >> -> False
| <:ctyp< $id:_$ >> -> True
| <:ctyp< $t$ $_$ >> -> loop t
| _ -> False ]
in
match t with
[ <:ctyp< $uid:_$ >> -> False
| t -> loop t ];
value contains_unknown t =
try
let (_ : < .. >) =
object
inherit Ast.fold as super;
method ctyp t = if is_unknown t then raise Exit else super#ctyp t;
end#ctyp t
in False
with [ Exit -> True ];
value opt_bind' ox e1 mk_e2 =
let mk_e2 =
match ox with
[ Some x -> fun e1 -> <:expr< $mk_e2 e1$ $x$ >>
| _ -> mk_e2 ]
in
opt_bind (opt_map patt_of_expr ox) e1 mk_e2;
(* FIXME finish me
value rec is_simple =
fun
[ <:expr< $id:_$ >> -> True
| <:expr< $e$#$_$ >> | <:expr< $tup:e$ >> -> is_simple e
| <:expr< $e1$ $e2$ >> | <:expr< $e1$, $e2$ >> -> is_simple e1 && is_simple e2
| _ -> False ];
value app e1 e2 =
let is_e1_simple = is_simple e1 in
let is_e2_simple = is_simple e2 in
if is_e1_simple then
if is_e2_simple then <:expr< $e1$ $e2$ >>
else let x = fresh "y" in <:expr< let $lid:y$ = $e2$ in $e1$ $lid:y$ >>
else
if is_e2_simple then
let x = fresh "y" in <:expr< let $lid:y$ = $e1$ in $lid:y$ $e2$ >>
else ; *)
value opt_app e ox =
match ox with
[ Some x -> <:expr< $e$ $x$ >> (* call app *)
| _ -> e ];
value rec expr_of_ty x ty =
let rec self ?(arity=0) ox =
fun
[ t when is_unknown t ->
self ox <:ctyp< unknown >>
| <:ctyp< $lid:id$ >> ->
let () = store_if_builtin_type id in
opt_bind' ox <:expr<o>> (fun e1 -> <:expr< $e1$#$id$ >>)
| <:ctyp@_loc< $t1$ $t2$ >> ->
let e = opt_bind None
(self ~arity:(arity+1) None t1)
(fun e1 -> <:expr< $e1$ $mkfuno (self None t2)$ >>) in
opt_app e ox
| <:ctyp< ( $tup:t$ ) >> ->
opt_app (mk_tuple (self ~arity:0) t) ox
| <:ctyp< '$s$ >> ->
opt_app <:expr< $lid:"_f_" ^ s$ o >> ox
| _ ->
self ox <:ctyp< unknown >> ]
in self x ty
and expr_of_ty' e t = expr_of_ty (Some e) t
and out_constr_patt s =
<:patt< $uid:s$ >>
(* <:patt< `$s$ >>
<:patt< M.$uid:s$ >> *)
and out_constr_expr s =
<:expr< $uid:s$ >>
(* <:expr< `$s$ >>
<:expr< M.$uid:s$ >> *)
(* method term t =
match t with
| C(x1, ..., xn) ->
let o, x1 = o#t1 x1 in
let o, x2 = o#t2 x2 in
...
let o, xn = o#tn xn in
o, C(x1, ..., xn)
*)
(* s = C, t = t1 and ... and tN *)
and match_case_of_constructor s t =
chain_tuple
(apply_patt (out_constr_patt s))
(apply_expr (out_constr_expr s))
expr_of_ty (Ast.list_of_ctyp t [])
and match_case_of_sum_type =
fun
[ <:ctyp< $t1$ | $t2$ >> ->
<:match_case< $match_case_of_sum_type t1$ | $match_case_of_sum_type t2$ >>
| <:ctyp< $uid:s$ of $t$ >> -> match_case_of_constructor s t
| <:ctyp< $uid:s$ >> -> match_case_of_constructor s <:ctyp<>>
| _ -> assert False ]
and match_case_of_poly_constructor s ts =
chain_tuple
(fun [ [] -> <:patt< `$s$ >> | [p] -> <:patt< `$s$ $p$ >> | ps -> <:patt< `$s$ ($tup:Ast.paCom_of_list ps$) >> ])
(fun [ [] -> <:expr< `$s$ >> | [e] -> <:expr< `$s$ $e$ >> | es -> <:expr< `$s$ ($tup:Ast.exCom_of_list es$) >> ])
expr_of_ty ts
and match_case_of_poly_sum_type =
fun
[ <:ctyp< $t1$ | $t2$ >> ->
<:match_case< $match_case_of_poly_sum_type t1$ | $match_case_of_poly_sum_type t2$ >>
| <:ctyp< `$i$ of ($tup:t$) >> -> match_case_of_poly_constructor i (Ast.list_of_ctyp t [])
| <:ctyp< `$i$ of $t$ >> -> match_case_of_poly_constructor i [t]
| <:ctyp< `$i$ >> -> match_case_of_poly_constructor i []
| _ -> assert False ]
and record_patt_of_type k =
fun
[ <:ctyp< $lid:s$ : $_$ >> ->
<:patt< $lid:s$ = $lid:xsk s k$ >>
| <:ctyp< $t1$ ; $t2$ >> ->
<:patt< $record_patt_of_type k t1$; $record_patt_of_type k t2$ >>
| _ -> assert False ]
and type_list_of_record_type t ((acc1, acc2) as acc) =
match t with
[ <:ctyp<>> -> acc
| <:ctyp< $lid:s$ : mutable $t$ >> | <:ctyp< $lid:s$ : $t$ >> ->
([s :: acc1], [t :: acc2])
| <:ctyp< $t1$ ; $t2$ >> ->
type_list_of_record_type t1 (type_list_of_record_type t2 acc)
| _ -> assert False ]
and expr_of_record_type t =
let (ls, ts) = type_list_of_record_type t ([], []) in
let mkp ps = <:patt< { $list:List.map2 (fun l p -> <:patt< $lid:l$ = $p$ >>) ls ps$ } >> in
let mke es = <:expr< { $list:List.map2 (fun l e -> <:rec_binding< $lid:l$ = $e$ >>) ls es$ } >> in
chain_tuple mkp mke expr_of_ty ts
and failure_match_case =
<:match_case< $tuplify_patt (pxik 0)$ ->
o#$lid:sf "%s%d_failure" (string_of_mode mode) size$ $tuplify_expr (exik 0)$ >>
and complete_match_case mk t =
match t with
[ <:ctyp< $_$ | $_$ >> when size > 1 ->
<:match_case< $mk t$ | $failure_match_case$ >>
| _ -> mk t ]
and fun_of_ctyp tyid =
fun
[ <:ctyp< [ $t$ ] >> ->
<:expr< fun [ $complete_match_case match_case_of_sum_type t$ ] >>
| <:ctyp< { $t$ } >> ->
<:expr< fun [ $expr_of_record_type t$ ] >>
| <:ctyp< ( $tup:t$ ) >> -> mk_tuple expr_of_ty t
| <:ctyp< $lid:i$ >> when i = tyid -> default_expr
| <:ctyp< $_$ $_$ >> | <:ctyp< $_$ -> $_$ >> | <:ctyp< '$_$ >> | <:ctyp< $id:_$ >> as t ->
expr_of_ty None t
| <:ctyp<>> ->
expr_of_ty None <:ctyp< unknown >>
| <:ctyp< [ = $t$ ] >> | <:ctyp< [ < $t$ ] >> | <:ctyp< private [ < $t$ ] >> ->
<:expr< fun [ $complete_match_case match_case_of_poly_sum_type t$ ] >>
| <:ctyp< [ > $t$ ] >> | <:ctyp< private [ > $t$ ] >> ->
if size > 1 then
<:expr< fun [ $complete_match_case match_case_of_poly_sum_type t$ ] >>
else
<:expr< fun [ $match_case_of_poly_sum_type t$ | $default_match_case$ ] >>
| _ -> assert False ]
and string_of_type_param t =
match t with
[ <:ctyp< '$s$ >> | <:ctyp< +'$s$ >> | <:ctyp< -'$s$ >> -> s
| _ -> assert False ]
and method_of_type_decl _ ((id1, _, params, ctyp, priv) as type_decl) acc =
let rec lambda acc =
fun
[ [] -> acc
| [ x :: xs ] -> lambda <:expr< fun $lid:"_f_" ^ x$ -> $acc$ >> xs ] in
let params' = List.map string_of_type_param params in
let funs = lambda (fun_of_ctyp id1 ctyp) params' in
let ty = method_type_of_type_decl type_decl in
let priv = if priv then <:private_flag< private >> else <:private_flag<>> in
<:class_str_item< method $private:priv$ $lid:id1$ : $ty$ = $funs$; $acc$ >>
and ctyp_name_of_name_params name params =
apply_ctyp <:ctyp< $id:name$ >> params
and method_type_of_type_decl (_, name, params, ctyp, _) =
let t = ctyp_name_of_name_params name params in
if mode = Map && not (contains_unknown ctyp) then
let out_params = List.map (fun [ <:ctyp< '$i$ >> -> <:ctyp< '$i^"_out"$ >> | _ -> assert False ]) params in
let t_out = ctyp_name_of_name_params name out_params in
method_type_of_type t t_out params out_params
else
method_type_of_type t t params []
and method_type_of_type t_in t_out params_in params_out =
let rt t =
match mode with
[ Fold_map -> <:ctyp< ('self_type * $t$) >>
| Fold -> <:ctyp< 'self_type >>
| Map -> t ]
in
match (params_in, params_out) with
[ ([param_in], [param_out]) ->
let alphas = tuplify_type param_in in
<:ctyp< ! $param_in$ $param_out$ . ('self_type -> $alphas$ -> $rt param_out$) -> $tuplify_type t_in$ -> $rt t_out$ >>
| ([param], []) ->
let alphas = tuplify_type param in
<:ctyp< ! $param$ . ('self_type -> $alphas$ -> $rt param$) -> $tuplify_type t_in$ -> $rt t_out$ >>
| ([], []) ->
<:ctyp< $tuplify_type t_in$ -> $rt t_out$ >>
| _ ->
let i = List.length params_in in
failwith (Printf.sprintf
"Camlp4FoldGenerator: FIXME not implemented for types with %d parameters" i) ]
and class_sig_item_of_type_decl _ ((name, _, _, t, _) as type_decl) acc =
let (_ : < .. >) =
object (self)
inherit Ast.fold as super;
method ctyp =
fun
[ <:ctyp< $lid:id$ >> -> let () = store_if_builtin_type id in self
| t -> super#ctyp t ];
end#ctyp t
in
<:class_sig_item<
method $lid:name$ : $method_type_of_type_decl type_decl$;
$acc$ >>
and generate_structure tyMap =
StringMap.fold method_of_type_decl used_builtins.val
(StringMap.fold method_of_type_decl tyMap <:class_str_item<>>)
and generate_signature tyMap =
StringMap.fold class_sig_item_of_type_decl used_builtins.val
(StringMap.fold class_sig_item_of_type_decl tyMap <:class_sig_item<>>);
end;
value rec tyMap_of_type_decls t acc =
match t with
[ <:ctyp<>> -> acc
| <:ctyp< $t1$ and $t2$ >> ->
tyMap_of_type_decls t1 (tyMap_of_type_decls t2 acc)
| Ast.TyDcl _ name tl tk _ ->
StringMap.add name (name, <:ident< $lid:name$ >>, tl, tk, False) acc
| _ -> assert False ];
value generate_class_implem ?(virtual_flag=False) mode c tydcl n =
let tyMap = tyMap_of_type_decls tydcl StringMap.empty in
let module M = Gen(struct value size = n; value mode = mode; end) in
let generated = M.generate_structure tyMap in
let gen_type =
<:ctyp< ! 'a 'b . $M.method_type_of_type <:ctyp< 'a >> <:ctyp< 'b >> [] []$ >>
in
let failure =
if n > 1 then
let name = string_of_mode mode in
<:class_str_item< method $lid:sf "%s%d_failure" name n$ : $gen_type$ =
fun $M.tuplify_patt (pxik 0)$ ->
failwith $`str:sf "%s%d_failure: default implementation" name n$ >>
else <:class_str_item<>>
in
let gen_type =
<:ctyp< ! 'a . $M.method_type_of_type <:ctyp< 'a >> <:ctyp< 'a >> [] []$ >>
in
let unknown =
<:class_str_item< method unknown : $gen_type$ = $M.default_expr$ >> in
if not virtual_flag then
<:str_item< class $lid:c$ = object (o : 'self_type) $generated$; $failure$; $unknown$ end >>
else
<:str_item< class virtual $lid:c$ = object (o : 'self_type) $generated$; $failure$; $unknown$ end >>;
value generate_class_interf ?(virtual_flag=False) mode c tydcl n =
let tyMap = tyMap_of_type_decls tydcl StringMap.empty in
let module M = Gen(struct value size = n; value mode = mode; end) in
let generated = M.generate_signature tyMap in
let gen_type =
<:ctyp< ! 'a 'b . $M.method_type_of_type <:ctyp< 'a >> <:ctyp< 'b >> [] []$ >>
in
let failure =
if n > 1 then
let name = string_of_mode mode in
<:class_sig_item< method $lid:sf "%s%d_failure" name n$ : $gen_type$ >>
else <:class_sig_item<>>
in
let gen_type =
<:ctyp< ! 'a . $M.method_type_of_type <:ctyp< 'a >> <:ctyp< 'a >> [] []$ >>
in
let unknown =
<:class_sig_item< method unknown : $gen_type$ >>
in
if not virtual_flag then
<:sig_item< class $lid:c$ : object ('self_type) $generated$; $failure$; $unknown$ end >>
else
<:sig_item< class virtual $lid:c$ : object ('self_type) $generated$; $failure$; $unknown$ end >> ;
value processor =
let last = ref <:ctyp<>> in
let generate_class' generator default c s n =
match s with
[ "Fold" -> generator Fold c last.val n
| "Map" -> generator Map c last.val n
| "FoldMap" -> generator Fold_map c last.val n
| _ -> default ]
in
let generate_class_from_module_name generator c default m =
try Scanf.sscanf m "Camlp4%[^G]Generator" begin fun m' ->
try Scanf.sscanf m' "%[^0-9]%d" (generate_class' generator default c)
with [ End_of_file | Scanf.Scan_failure _ -> generate_class' generator default c m' 1 ]
end with [ End_of_file | Scanf.Scan_failure _ -> default ]
in
object (self)
inherit Ast.map as super;
method str_item st =
match st with
[ <:str_item< type $t$ >> -> (last.val := t; st)
(* backward compatibility *)
| <:str_item@_loc< class $lid:c$ = Camlp4Filters.GenerateFold.generated >> ->
generate_class_implem Fold c last.val 1
| <:str_item@_loc< class virtual $lid:c$ = Camlp4Filters.GenerateFold.generated >> ->
generate_class_implem ~virtual_flag:True Fold c last.val 1
| <:str_item@_loc< class $lid:c$ = Camlp4Filters.GenerateMap.generated >> ->
generate_class_implem Map c last.val 1
| <:str_item@_loc< class virtual $lid:c$ = Camlp4Filters.GenerateMap.generated >> ->
generate_class_implem ~virtual_flag:True Map c last.val 1
(* Handle Camlp4(Fold|Map|FoldMap)\d*Generator *)
| <:str_item@_loc< class $lid:c$ = $uid:m$.generated >> ->
generate_class_from_module_name (generate_class_implem ~virtual_flag:False) c st m
| <:str_item@_loc< class virtual $lid:c$ = $uid:m$.generated >> ->
generate_class_from_module_name (generate_class_implem ~virtual_flag:True) c st m
(* It's a hack to force to recurse on the left to right order *)
| <:str_item< $st1$; $st2$ >> ->
let st1 = self#str_item st1 in
<:str_item< $st1$; $self#str_item st2$ >>
| st -> super#str_item st ];
method sig_item sg =
match sg with
[ <:sig_item< type $t$ >> -> (last.val := t; sg)
(* backward compatibility *)
| <:sig_item@_loc< class $lid:c$ : Camlp4Filters.GenerateFold.generated >> ->
generate_class_interf Fold c last.val 1
| <:sig_item@_loc< class virtual $lid:c$ : Camlp4Filters.GenerateFold.generated >> ->
generate_class_interf ~virtual_flag:True Fold c last.val 1
| <:sig_item@_loc< class $lid:c$ : Camlp4Filters.GenerateMap.generated >> ->
generate_class_interf Map c last.val 1
| <:sig_item@_loc< class virtual $lid:c$ : Camlp4Filters.GenerateMap.generated >> ->
generate_class_interf ~virtual_flag:True Map c last.val 1
(* Handle Camlp4(Fold|Map|FoldMap)\d*Generator *)
| <:sig_item@_loc< class $lid:c$ : $uid:m$.generated >> ->
generate_class_from_module_name (generate_class_interf ~virtual_flag:False) c sg m
| <:sig_item@_loc< class virtual $lid:c$ : $uid:m$.generated >> ->
generate_class_from_module_name (generate_class_interf ~virtual_flag:True) c sg m
(* It's a hack to force to recurse on the left to right order *)
| <:sig_item< $sg1$; $sg2$ >> ->
let sg1 = self#sig_item sg1 in
<:sig_item< $sg1$; $self#sig_item sg2$ >>
| sg -> super#sig_item sg ];
end;
register_str_item_filter processor#str_item;
register_sig_item_filter processor#sig_item;
end;
let module M = Camlp4.Register.AstFilter Id Make in ();

36
camlp4/Camlp4Filters/Camlp4LocationStripper.ml
View File

@ -1,36 +0,0 @@
(* camlp4r *)
(****************************************************************************)
(* *)
(* OCaml *)
(* *)
(* INRIA Rocquencourt *)
(* *)
(* Copyright 2006 Institut National de Recherche en Informatique et *)
(* en Automatique. All rights reserved. This file is distributed under *)
(* the terms of the GNU Library General Public License, with the special *)
(* exception on linking described in LICENSE at the top of the OCaml *)
(* source tree. *)
(* *)
(****************************************************************************)
(* Authors:
* - Nicolas Pouillard: initial version
*)
open Camlp4;
module Id = struct
value name = "Camlp4LocationStripper";
value version = Sys.ocaml_version;
end;
module Make (AstFilters : Camlp4.Sig.AstFilters) = struct
open AstFilters;
open Ast;
register_str_item_filter (Ast.map_loc (fun _ -> Loc.ghost))#str_item;
end;
let module M = Camlp4.Register.AstFilter Id Make in ();

19
camlp4/Camlp4Filters/Camlp4MapGenerator.ml
View File

@ -1,19 +0,0 @@
(****************************************************************************)
(* *)
(* OCaml *)
(* *)
(* INRIA Rocquencourt *)
(* *)
(* Copyright 2007 Institut National de Recherche en Informatique et *)
(* en Automatique. All rights reserved. This file is distributed under *)
(* the terms of the GNU Library General Public License, with the special *)
(* exception on linking described in LICENSE at the top of the OCaml *)
(* source tree. *)
(* *)
(****************************************************************************)
(* This module is useless now. Camlp4FoldGenerator handles map too. *)
module Id = struct
value name = "Camlp4MapGenerator";
value version = Sys.ocaml_version;
end;

212
camlp4/Camlp4Filters/Camlp4MetaGenerator.ml
View File

@ -1,212 +0,0 @@
(****************************************************************************)
(* *)
(* OCaml *)
(* *)
(* INRIA Rocquencourt *)
(* *)
(* Copyright 2007 Institut National de Recherche en Informatique et *)
(* en Automatique. All rights reserved. This file is distributed under *)
(* the terms of the GNU Library General Public License, with the special *)
(* exception on linking described in LICENSE at the top of the OCaml *)
(* source tree. *)
(* *)
(****************************************************************************)
open Camlp4;
open PreCast;
module MapTy = Map.Make String;
type t =
{ name : Ast.ident;
type_decls : MapTy.t Ast.ctyp;
acc : Ast.expr;
app : Ast.expr;
id : Ast.expr;
tup : Ast.expr;
com : Ast.expr;
str : Ast.expr;
int : Ast.expr;
flo : Ast.expr;
chr : Ast.expr;
ant : Ast.ident;
};
value _loc = Loc.ghost;
value x i = <:ident< $lid:"x"^string_of_int i$ >>;
value meta_ s = <:ident< $lid:"meta_"^s$ >>;
value mf_ s = "mf_" ^ s;
value rec string_of_ident =
fun
[ <:ident< $lid:s$ >> -> s
| <:ident< $uid:s$ >> -> s
| <:ident< $i1$.$i2$ >> -> "acc_" ^ (string_of_ident i1) ^ "_" ^ (string_of_ident i2)
| <:ident< $i1$ $i2$ >> -> "app_" ^ (string_of_ident i1) ^ "_" ^ (string_of_ident i2)
| <:ident< $anti:_$ >> -> assert False ];
value fold_args ty f init =
let (_, res) =
List.fold_left begin fun (i, acc) ty ->
(succ i, f ty i acc)
end (0, init) ty
in res;
value fold_data_ctors ty f init =
let rec loop acc t =
match t with
[ <:ctyp< $uid:cons$ of $ty$ >> -> f cons (Ast.list_of_ctyp ty []) acc
| <:ctyp< $uid:cons$ >> -> f cons [] acc
| <:ctyp< $t1$ | $t2$ >> -> loop (loop acc t1) t2
| <:ctyp<>> -> acc
| _ -> assert False ] in
loop init ty;
value fold_type_decls m f init =
MapTy.fold f m.type_decls init;
value patt_of_data_ctor_decl cons tyargs =
fold_args tyargs begin fun _ i acc ->
<:patt< $acc$ $id:x i$ >>
end <:patt< $id:cons$ >>;
value expr_of_data_ctor_decl cons tyargs =
fold_args tyargs begin fun _ i acc ->
<:expr< $acc$ $id:x i$ >>
end <:expr< $id:cons$ >>;
value is_antiquot_data_ctor s =
let ls = String.length s in
ls > 3 && String.sub s (ls - 3) 3 = "Ant";
value rec meta_ident m =
fun
[ <:ident< $i1$.$i2$ >> -> <:expr< Ast.IdAcc _loc $meta_ident m i1$ $meta_ident m i2$ >>
| <:ident< $i1$ $i2$ >> -> <:expr< Ast.IdApp _loc $meta_ident m i1$ $meta_ident m i2$ >>
| <:ident< $anti:s$ >> -> <:expr< $anti:s$ >>
| <:ident< $lid:s$ >> -> <:expr< Ast.IdLid _loc $str:s$ >>
| <:ident< $uid:s$ >> -> <:expr< Ast.IdUid _loc $str:s$ >> ];
value m_app m x y = <:expr< $m.app$ _loc $x$ $y$ >>;
value m_id m i = <:expr< $m.id$ _loc $i$ >>;
value m_uid m s = m_id m (meta_ident m <:ident< $uid:s$ >>);
value failure = <:expr< raise (Failure "MetaGenerator: cannot handle that kind of types") >>;
value mk_meta m =
let m_name_uid x = <:ident< $m.name$.$uid:x$ >> in
fold_type_decls m begin fun tyname tydcl binding_acc ->
match tydcl with
[ Ast.TyDcl _ _ tyvars <:ctyp< [$ty$] >> _ ->
let match_case =
fold_data_ctors ty begin fun cons tyargs acc ->
let m_name_cons = m_name_uid cons in
let init = m_id m (meta_ident m m_name_cons) in
let p = patt_of_data_ctor_decl m_name_cons tyargs in
let e =
if List.mem cons ["BAnt"; "OAnt"; "LAnt"; "ReAnt"; "DiAnt";
"MuAnt"; "PrAnt"; "ViAnt"; "OvAnt"; "RvAnt"] then
<:expr< $id:m.ant$ _loc x0 >>
else if is_antiquot_data_ctor cons then
expr_of_data_ctor_decl m.ant tyargs
else
fold_args tyargs begin fun ty i acc ->
let rec fcall_of_ctyp ty =
match ty with
[ <:ctyp< $id:id$ >> ->
<:expr< $id:meta_ (string_of_ident id)$ >>
| <:ctyp< ($t1$ * $t2$) >> ->
<:expr< fun _loc (x1, x2) ->
$m.tup$ _loc
($m.com$ _loc
($fcall_of_ctyp t1$ _loc x1)
($fcall_of_ctyp t2$ _loc x2)) >>
| <:ctyp< $t1$ $t2$ >> ->
<:expr< $fcall_of_ctyp t1$ $fcall_of_ctyp t2$ >>
| <:ctyp< '$s$ >> -> <:expr< $lid:mf_ s$ >>
| _ -> failure ]
in m_app m acc <:expr< $fcall_of_ctyp ty$ _loc $id:x i$ >>
end init
in <:match_case< $p$ -> $e$ | $acc$ >>
end <:match_case<>> in
let funct =
List.fold_right begin fun tyvar acc ->
match tyvar with
[ <:ctyp< +'$s$ >> | <:ctyp< -'$s$ >> | <:ctyp< '$s$ >> ->
<:expr< fun $lid:mf_ s$ -> $acc$ >>
| _ -> assert False ]
end tyvars <:expr< fun _loc -> fun [ $match_case$ ] >>
in <:binding< $binding_acc$ and $lid:"meta_"^tyname$ = $funct$ >>
| Ast.TyDcl _ _ _ _ _ -> binding_acc
| _ -> assert False ]
end <:binding<>>;
value find_type_decls = object
inherit Ast.fold as super;
value accu = MapTy.empty;
method get = accu;
method ctyp =
fun
[ Ast.TyDcl _ name _ _ _ as t -> {< accu = MapTy.add name t accu >}
| t -> super#ctyp t ];
end;
value filter st =
let type_decls = lazy (find_type_decls#str_item st)#get in
object
inherit Ast.map as super;
method module_expr me =
let mk_meta_module m =
let bi = mk_meta m in
<:module_expr<
struct
value meta_string _loc s = $m.str$ _loc (safe_string_escaped s);
value meta_int _loc s = $m.int$ _loc s;
value meta_float _loc s = $m.flo$ _loc s;
value meta_char _loc s = $m.chr$ _loc (String.escaped s);
value meta_bool _loc =
fun
[ False -> $m_uid m "False"$
| True -> $m_uid m "True"$ ];
value rec meta_list mf_a _loc =
fun
[ [] -> $m_uid m "[]"$
| [x :: xs] -> $m_app m (m_app m (m_uid m "::") <:expr< mf_a _loc x >>) <:expr< meta_list mf_a _loc xs >>$ ];
value rec $bi$;
end >> in
match super#module_expr me with
[ <:module_expr< Camlp4Filters.MetaGeneratorExpr $id:i$ >> ->
mk_meta_module
{ name = i;
type_decls = Lazy.force type_decls;
app = <:expr< Ast.ExApp >>;
acc = <:expr< Ast.ExAcc >>;
id = <:expr< Ast.ExId >>;
tup = <:expr< Ast.ExTup >>;
com = <:expr< Ast.ExCom >>;
str = <:expr< Ast.ExStr >>;
int = <:expr< Ast.ExInt >>;
flo = <:expr< Ast.ExFlo >>;
chr = <:expr< Ast.ExChr >>;
ant = <:ident< Ast.ExAnt >>
}
| <:module_expr< Camlp4Filters.MetaGeneratorPatt $id:i$ >> ->
mk_meta_module
{ name = i;
type_decls = Lazy.force type_decls;
app = <:expr< Ast.PaApp >>;
acc = <:expr< Ast.PaAcc >>;
id = <:expr< Ast.PaId >>;
tup = <:expr< Ast.PaTup >>;
com = <:expr< Ast.PaCom >>;
str = <:expr< Ast.PaStr >>;
int = <:expr< Ast.PaInt >>;
flo = <:expr< Ast.PaFlo >>;
chr = <:expr< Ast.PaChr >>;
ant = <:ident< Ast.PaAnt >>
}
| me -> me ];
end#str_item st;
AstFilters.register_str_item_filter filter;

77
camlp4/Camlp4Filters/Camlp4Profiler.ml
View File

@ -1,77 +0,0 @@
(* camlp4r *)
(****************************************************************************)
(* *)
(* OCaml *)
(* *)
(* INRIA Rocquencourt *)
(* *)
(* Copyright 2006 Institut National de Recherche en Informatique et *)
(* en Automatique. All rights reserved. This file is distributed under *)
(* the terms of the GNU Library General Public License, with the special *)
(* exception on linking described in LICENSE at the top of the OCaml *)
(* source tree. *)
(* *)
(****************************************************************************)
(* Authors:
* - Nicolas Pouillard: initial version
*)
open Camlp4;
module Id = struct
value name = "Camlp4Profiler";
value version = Sys.ocaml_version;
end;
module Make (AstFilters : Camlp4.Sig.AstFilters) = struct
open AstFilters;
open Ast;
value decorate_binding decorate_fun = object
inherit Ast.map as super;
method binding =
fun
[ <:binding@_loc< $lid:id$ = $(<:expr< fun [ $_$ ] >> as e)$ >> ->
<:binding< $lid:id$ = $decorate_fun id e$ >>
| b -> super#binding b ];
end#binding;
value decorate decorate_fun = object (o)
inherit Ast.map as super;
method str_item =
fun
[ <:str_item@_loc< value $rec:r$ $b$ >> ->
<:str_item< value $rec:r$ $decorate_binding decorate_fun b$ >>
| st -> super#str_item st ];
method expr =
fun
[ <:expr@_loc< let $rec:r$ $b$ in $e$ >> ->
<:expr< let $rec:r$ $decorate_binding decorate_fun b$ in $o#expr e$ >>
| <:expr@_loc< fun [ $_$ ] >> as e -> decorate_fun "<fun>" e
| e -> super#expr e ];
end;
value decorate_this_expr e id =
let buf = Buffer.create 42 in
let _loc = Ast.loc_of_expr e in
let () = Format.bprintf buf "%s @@ %a@?" id Loc.dump _loc in
let s = Buffer.contents buf in
<:expr< let () = Camlp4prof.count $`str:s$ in $e$ >>;
value rec decorate_fun id =
let decorate = decorate decorate_fun in
let decorate_expr = decorate#expr in
let decorate_match_case = decorate#match_case in
fun
[ <:expr@_loc< fun $p$ -> $e$ >> ->
<:expr< fun $p$ -> $decorate_fun id e$ >>
| <:expr@_loc< fun [ $m$ ] >> ->
decorate_this_expr <:expr< fun [ $decorate_match_case m$ ] >> id
| e -> decorate_this_expr (decorate_expr e) id ];
register_str_item_filter (decorate decorate_fun)#str_item;
end;
let module M = Camlp4.Register.AstFilter Id Make in ();

41
camlp4/Camlp4Filters/Camlp4TrashRemover.ml
View File

@ -1,41 +0,0 @@
(* camlp4r *)
(****************************************************************************)
(* *)
(* OCaml *)
(* *)
(* INRIA Rocquencourt *)
(* *)
(* Copyright 2006 Institut National de Recherche en Informatique et *)
(* en Automatique. All rights reserved. This file is distributed under *)
(* the terms of the GNU Library General Public License, with the special *)
(* exception on linking described in LICENSE at the top of the OCaml *)
(* source tree. *)
(* *)
(****************************************************************************)
(* Authors:
* - Nicolas Pouillard: initial version
*)
open Camlp4;
module Id = struct
value name = "Camlp4TrashRemover";
value version = Sys.ocaml_version;
end;
module Make (AstFilters : Camlp4.Sig.AstFilters) = struct
open AstFilters;
open Ast;
register_str_item_filter
(Ast.map_str_item
(fun
[ <:str_item@_loc< module Camlp4Trash = $_$ >> ->
<:str_item<>>
| st -> st ]))#str_item;
end;
let module M = Camlp4.Register.AstFilter Id Make in ();

49
camlp4/Camlp4Parsers/Camlp4AstLoader.ml
View File

@ -1,49 +0,0 @@
(****************************************************************************)
(* *)
(* OCaml *)
(* *)
(* INRIA Rocquencourt *)
(* *)
(* Copyright 2006 Institut National de Recherche en Informatique et *)
(* en Automatique. All rights reserved. This file is distributed under *)
(* the terms of the GNU Library General Public License, with the special *)
(* exception on linking described in LICENSE at the top of the OCaml *)
(* source tree. *)
(* *)
(****************************************************************************)
(* Authors:
* - Daniel de Rauglaudre: initial version
* - Nicolas Pouillard: refactoring
*)
open Camlp4; (* -*- camlp4r -*- *)
module Id = struct
value name = "Camlp4AstLoader";
value version = Sys.ocaml_version;
end;
module Make (Ast : Camlp4.Sig.Ast) = struct
module Ast = Ast;
value parse ast_magic ?directive_handler:(_) _loc strm =
let str =
let buf = Buffer.create 2047 in
let () = Stream.iter (Buffer.add_char buf) strm
in Buffer.contents buf in
let magic_len = String.length ast_magic in
let buffer = String.create magic_len in
do {
String.blit str 0 buffer 0 magic_len;
if buffer = ast_magic then ()
else failwith (Format.sprintf "Bad magic: %S vs %S" buffer ast_magic);
Marshal.from_string str magic_len;
};
open Camlp4.PreCast;
value parse_implem = parse Camlp4_config.camlp4_ast_impl_magic_number;
value parse_interf = parse Camlp4_config.camlp4_ast_intf_magic_number;
end;
let module M = Camlp4.Register.Parser Id Make in ();

83
camlp4/Camlp4Parsers/Camlp4DebugParser.ml
View File

@ -1,83 +0,0 @@
open Camlp4; (* -*- camlp4r -*- *)
(****************************************************************************)
(* *)
(* OCaml *)
(* *)
(* INRIA Rocquencourt *)
(* *)
(* Copyright 2006 Institut National de Recherche en Informatique et *)
(* en Automatique. All rights reserved. This file is distributed under *)
(* the terms of the GNU Library General Public License, with the special *)
(* exception on linking described in LICENSE at the top of the OCaml *)
(* source tree. *)
(* *)
(****************************************************************************)
(* Authors:
* - Nicolas Pouillard: initial version
*)
module Id = struct
value name = "Camlp4DebugParser";
value version = Sys.ocaml_version;
end;
module Make (Syntax : Sig.Camlp4Syntax) = struct
open Sig;
include Syntax;
module StringSet = Set.Make String;
value debug_mode =
try
let str = Sys.getenv "STATIC_CAMLP4_DEBUG" in
let rec loop acc i =
try
let pos = String.index_from str i ':' in
loop (StringSet.add (String.sub str i (pos - i)) acc) (pos + 1)
with
[ Not_found ->
StringSet.add (String.sub str i (String.length str - i)) acc ] in
let sections = loop StringSet.empty 0 in
if StringSet.mem "*" sections then fun _ -> True
else fun x -> StringSet.mem x sections
with [ Not_found -> fun _ -> False ];
value rec apply accu =
fun
[ [] -> accu
| [x :: xs] ->
let _loc = Ast.loc_of_expr x
in apply <:expr< $accu$ $x$ >> xs ];
value mk_debug_mode _loc = fun [ None -> <:expr< Debug.mode >>
| Some m -> <:expr< $uid:m$.Debug.mode >> ];
value mk_debug _loc m fmt section args =
let call = apply <:expr< Debug.printf $str:section$ $str:fmt$ >> args in
<:expr< if $mk_debug_mode _loc m$ $str:section$ then $call$ else () >>;
EXTEND Gram
GLOBAL: expr;
expr:
[ [ m = start_debug; section = LIDENT; fmt = STRING;
args = LIST0 expr LEVEL "."; x = end_or_in ->
match (x, debug_mode section) with
[ (None, False) -> <:expr< () >>
| (Some e, False) -> e
| (None, _) -> mk_debug _loc m fmt section args
| (Some e, _) -> <:expr< let () = $mk_debug _loc m fmt section args$ in $e$ >> ]
] ];
end_or_in:
[ [ "end" -> None
| "in"; e = expr -> Some e
] ];
start_debug:
[ [ LIDENT "debug" -> None
| LIDENT "camlp4_debug" -> Some "Camlp4"
] ];
END;
end;
let module M = Register.OCamlSyntaxExtension Id Make in ();

898
camlp4/Camlp4Parsers/Camlp4GrammarParser.ml
View File

@ -1,898 +0,0 @@
open Camlp4; (* -*- camlp4r -*- *)
(****************************************************************************)
(* *)
(* OCaml *)
(* *)
(* INRIA Rocquencourt *)
(* *)
(* Copyright 2002-2006 Institut National de Recherche en Informatique et *)
(* en Automatique. All rights reserved. This file is distributed under *)
(* the terms of the GNU Library General Public License, with the special *)
(* exception on linking described in LICENSE at the top of the OCaml *)
(* source tree. *)
(* *)
(****************************************************************************)
(* Authors:
* - Daniel de Rauglaudre: initial version
* - Nicolas Pouillard: refactoring
*)
module Id = struct
value name = "Camlp4GrammarParser";
value version = Sys.ocaml_version;
end;
module Make (Syntax : Sig.Camlp4Syntax) = struct
open Sig;
include Syntax;
module MetaLoc = Ast.Meta.MetaGhostLoc;
module MetaAst = Ast.Meta.Make MetaLoc;
module PP = Camlp4.Printers.OCaml.Make Syntax;
value pp = new PP.printer ~comments:False ();
value string_of_patt patt =
let buf = Buffer.create 42 in
let () = Format.bprintf buf "%a@?" pp#patt patt in
let str = Buffer.contents buf in
if str = "" then assert False else str;
value split_ext = ref False;
type loc = Loc.t;
type name 'e = { expr : 'e; tvar : string; loc : loc };
type styp =
[ STlid of loc and string
| STapp of loc and styp and styp
| STquo of loc and string
| STself of loc and string
| STtok of loc
| STstring_tok of loc
| STtyp of Ast.ctyp ]
;
type text 'e 'p =
[ TXmeta of loc and string and list (text 'e 'p) and 'e and styp
| TXlist of loc and bool and symbol 'e 'p and option (symbol 'e 'p)
| TXnext of loc
| TXnterm of loc and name 'e and option string
| TXopt of loc and text 'e 'p
| TXtry of loc and text 'e 'p
| TXrules of loc and list (list (text 'e 'p) * 'e)
| TXself of loc
| TXkwd of loc and string
| TXtok of loc and 'e and string
(** The first is the match function expr,
the second is the string description.
The description string will be used for
grammar insertion and left factoring.
Keep this string normalized and well comparable. *) ]
and entry 'e 'p =
{ name : name 'e; pos : option 'e; levels : list (level 'e 'p) }
and level 'e 'p =
{ label : option string; assoc : option 'e; rules : list (rule 'e 'p) }
and rule 'e 'p = { prod : list (symbol 'e 'p); action : option 'e }
and symbol 'e 'p = { used : list string; text : text 'e 'p;
styp : styp; pattern : option 'p }
;
type used = [ Unused | UsedScanned | UsedNotScanned ];
value _loc = Loc.ghost;
value gm = "Camlp4Grammar__";
value mark_used modif ht n =
try
let rll = Hashtbl.find_all ht n in
List.iter
(fun (r, _) ->
if r.val == Unused then do {
r.val := UsedNotScanned; modif.val := True;
}
else ())
rll
with
[ Not_found -> () ]
;
value rec mark_symbol modif ht symb =
List.iter (fun e -> mark_used modif ht e) symb.used
;
value check_use nl el =
let ht = Hashtbl.create 301 in
let modif = ref False in
do {
List.iter
(fun e ->
let u =
match e.name.expr with
[ <:expr< $lid:_$ >> -> Unused
| _ -> UsedNotScanned ]
in
Hashtbl.add ht e.name.tvar (ref u, e))
el;
List.iter
(fun n ->
try
let rll = Hashtbl.find_all ht n.tvar in
List.iter (fun (r, _) -> r.val := UsedNotScanned) rll
with _ ->
())
nl;
modif.val := True;
while modif.val do {
modif.val := False;
Hashtbl.iter
(fun _ (r, e) ->
if r.val = UsedNotScanned then do {
r.val := UsedScanned;
List.iter
(fun level ->
let rules = level.rules in
List.iter
(fun rule ->
List.iter (fun s -> mark_symbol modif ht s)
rule.prod)
rules)
e.levels
}
else ())
ht
};
Hashtbl.iter
(fun s (r, e) ->
if r.val = Unused then
print_warning e.name.loc ("Unused local entry \"" ^ s ^ "\"")
else ())
ht;
}
;
value new_type_var =
let i = ref 0 in fun () -> do { incr i; "e__" ^ string_of_int i.val }
;
value used_of_rule_list rl =
List.fold_left
(fun nl r -> List.fold_left (fun nl s -> s.used @ nl) nl r.prod) []
rl
;
value retype_rule_list_without_patterns _loc rl =
try
List.map
(fun
(* ...; [ "foo" ]; ... ==> ...; (x = [ "foo" ] -> Gram.Token.extract_string x); ... *)
[ {prod = [({pattern = None; styp = STtok _} as s)]; action = None} ->
{prod = [{ (s) with pattern = Some <:patt< x >> }];
action = Some <:expr< $uid:gm$.Token.extract_string x >>}
(* ...; [ symb ]; ... ==> ...; (x = [ symb ] -> x); ... *)
| {prod = [({pattern = None} as s)]; action = None} ->
{prod = [{ (s) with pattern = Some <:patt< x >> }];
action = Some <:expr< x >>}
(* ...; ([] -> a); ... *)
| {prod = []; action = Some _} as r -> r
| _ -> raise Exit ])
rl
with
[ Exit -> rl ]
;
value meta_action = ref False;
value mklistexp _loc =
loop True where rec loop top =
fun
[ [] -> <:expr< [] >>
| [e1 :: el] ->
let _loc =
if top then _loc else Loc.merge (Ast.loc_of_expr e1) _loc
in
<:expr< [$e1$ :: $loop False el$] >> ]
;
value mklistpat _loc =
loop True where rec loop top =
fun
[ [] -> <:patt< [] >>
| [p1 :: pl] ->
let _loc =
if top then _loc else Loc.merge (Ast.loc_of_patt p1) _loc
in
<:patt< [$p1$ :: $loop False pl$] >> ]
;
value rec expr_fa al =
fun
[ <:expr< $f$ $a$ >> -> expr_fa [a :: al] f
| f -> (f, al) ]
;
value rec make_ctyp styp tvar =
match styp with
[ STlid _loc s -> <:ctyp< $lid:s$ >>
| STapp _loc t1 t2 -> <:ctyp< $make_ctyp t1 tvar$ $make_ctyp t2 tvar$ >>
| STquo _loc s -> <:ctyp< '$s$ >>
| STself _loc x ->
if tvar = "" then
Loc.raise _loc
(Stream.Error ("'" ^ x ^ "' illegal in anonymous entry level"))
else <:ctyp< '$tvar$ >>
| STtok _loc -> <:ctyp< $uid:gm$.Token.t >>
| STstring_tok _loc -> <:ctyp< string >>
| STtyp t -> t ]
;
value make_ctyp_patt styp tvar patt =
let styp = match styp with [ STstring_tok _loc -> STtok _loc | t -> t ] in
match make_ctyp styp tvar with
[ <:ctyp< _ >> -> patt
| t -> let _loc = Ast.loc_of_patt patt in <:patt< ($patt$ : $t$) >> ];
value make_ctyp_expr styp tvar expr =
match make_ctyp styp tvar with
[ <:ctyp< _ >> -> expr
| t -> let _loc = Ast.loc_of_expr expr in <:expr< ($expr$ : $t$) >> ];
value text_of_action _loc psl rtvar act tvar =
let locid = <:patt< $lid:Loc.name.val$ >> in
let act =
match act with
[ Some act -> act
| None -> <:expr< () >> ]
in
let (tok_match_pl, act, _) =
List.fold_left
(fun ((tok_match_pl, act, i) as accu) ->
fun
[ { pattern = None } -> accu
| { pattern = Some p } when Ast.is_irrefut_patt p -> accu
| { pattern = Some <:patt< ($_$ ($tup:<:patt< _ >>$) as $lid:s$) >> } ->
(tok_match_pl,
<:expr< let $lid:s$ = $uid:gm$.Token.extract_string $lid:s$
in $act$ >>, i)
| { pattern = Some p; text=TXtok _ _ _ } ->
let id = "__camlp4_"^string_of_int i in
(Some (match (tok_match_pl) with
[ None -> (<:expr< $lid:id$ >>, p)
| Some (tok_pl, match_pl) ->
(<:expr< $lid:id$, $tok_pl$ >>, <:patt< $p$, $match_pl$ >>)]),
act, succ i)
| _ -> accu ])
(None, act, 0) psl
in
let e =
let e1 = <:expr< ($act$ : '$rtvar$) >> in
let e2 =
match (tok_match_pl) with
[ None -> e1
| Some (<:expr< $t1$, $t2$ >>, <:patt< $p1$, $p2$ >>) ->
<:expr< match ($t1$, $t2$) with
[ ($p1$, $p2$) -> $e1$
| _ -> assert False ] >>
| Some (tok, match_) ->
<:expr< match $tok$ with
[ $pat:match_$ -> $e1$
| _ -> assert False ] >> ] in
<:expr< fun ($locid$ : $uid:gm$.Loc.t) -> $e2$ >> in
let (txt, _) =
List.fold_left
(fun (txt, i) s ->
match s.pattern with
[ None | Some <:patt< _ >> -> (<:expr< fun _ -> $txt$ >>, i)
| Some <:patt< ($_$ ($tup:<:patt< _ >>$) as $p$) >> ->
let p = make_ctyp_patt s.styp tvar p in
(<:expr< fun $p$ -> $txt$ >>, i)
| Some p when Ast.is_irrefut_patt p ->
let p = make_ctyp_patt s.styp tvar p in
(<:expr< fun $p$ -> $txt$ >>, i)
| Some _ ->
let p = make_ctyp_patt s.styp tvar
<:patt< $lid:"__camlp4_"^string_of_int i$ >> in
(<:expr< fun $p$ -> $txt$ >>, succ i) ])
(e, 0) psl
in
let txt =
if meta_action.val then
<:expr< Obj.magic $MetaAst.Expr.meta_expr _loc txt$ >>
else txt
in
<:expr< $uid:gm$.Action.mk $txt$ >>
;
value srules loc t rl tvar =
List.map
(fun r ->
let sl = [ s.text | s <- r.prod ] in
let ac = text_of_action loc r.prod t r.action tvar in
(sl, ac))
rl
;
value rec make_expr entry tvar =
fun
[ TXmeta _loc n tl e t ->
let el =
List.fold_right
(fun t el -> <:expr< [$make_expr entry "" t$ :: $el$] >>)
tl <:expr< [] >>
in
<:expr<
$uid:gm$.Smeta $str:n$ $el$ ($uid:gm$.Action.mk ($make_ctyp_expr t tvar e$)) >>
| TXlist _loc min t ts ->
let txt = make_expr entry "" t.text in
match (min, ts) with
[ (False, None) -> <:expr< $uid:gm$.Slist0 $txt$ >>
| (True, None) -> <:expr< $uid:gm$.Slist1 $txt$ >>
| (False, Some s) ->
let x = make_expr entry tvar s.text in
<:expr< $uid:gm$.Slist0sep $txt$ $x$ >>
| (True, Some s) ->
let x = make_expr entry tvar s.text in
<:expr< $uid:gm$.Slist1sep $txt$ $x$ >> ]
| TXnext _loc -> <:expr< $uid:gm$.Snext >>
| TXnterm _loc n lev ->
match lev with
[ Some lab ->
<:expr<
$uid:gm$.Snterml
($uid:gm$.Entry.obj ($n.expr$ : $uid:gm$.Entry.t '$n.tvar$))
$str:lab$ >>
| None ->
if n.tvar = tvar then <:expr< $uid:gm$.Sself >>
else
<:expr<
$uid:gm$.Snterm
($uid:gm$.Entry.obj ($n.expr$ : $uid:gm$.Entry.t '$n.tvar$)) >> ]
| TXopt _loc t -> <:expr< $uid:gm$.Sopt $make_expr entry "" t$ >>
| TXtry _loc t -> <:expr< $uid:gm$.Stry $make_expr entry "" t$ >>
| TXrules _loc rl ->
<:expr< $uid:gm$.srules $entry.expr$ $make_expr_rules _loc entry rl ""$ >>
| TXself _loc -> <:expr< $uid:gm$.Sself >>
| TXkwd _loc kwd -> <:expr< $uid:gm$.Skeyword $str:kwd$ >>
| TXtok _loc match_fun descr ->
<:expr< $uid:gm$.Stoken ($match_fun$, $`str:descr$) >> ]
and make_expr_rules _loc n rl tvar =
List.fold_left
(fun txt (sl, ac) ->
let sl =
List.fold_right
(fun t txt ->
let x = make_expr n tvar t in
<:expr< [$x$ :: $txt$] >>)
sl <:expr< [] >>
in
<:expr< [($sl$, $ac$) :: $txt$] >>)
<:expr< [] >> rl
;
value expr_of_delete_rule _loc n sl =
let sl =
List.fold_right
(fun s e -> <:expr< [$make_expr n "" s.text$ :: $e$] >>) sl
<:expr< [] >>
in
(<:expr< $n.expr$ >>, sl)
;
value rec tvar_of_ident =
fun
[ <:ident< $lid:x$ >> | <:ident< $uid:x$ >> -> x
| <:ident< $uid:x$.$xs$ >> -> x ^ "__" ^ tvar_of_ident xs
| _ -> failwith "internal error in the Grammar extension" ]
;
value mk_name _loc i =
{expr = <:expr< $id:i$ >>; tvar = tvar_of_ident i; loc = _loc};
value slist loc min sep symb =
TXlist loc min symb sep
;
(*
value sstoken _loc s =
let n = mk_name _loc <:ident< $lid:"a_" ^ s$ >> in
TXnterm _loc n None
;
value mk_symbol p s t =
{used = []; text = s; styp = t; pattern=Some p};
value sslist _loc min sep s =
let rl =
let r1 =
let prod =
let n = mk_name _loc <:ident< a_list >> in
[mk_symbol <:patt< a >> (TXnterm _loc n None) (STquo _loc "a_list")]
in
let act = <:expr< a >> in
{prod = prod; action = Some act}
in
let r2 =
let prod =
[mk_symbol <:patt< a >> (slist _loc min sep s)
(STapp _loc (STlid _loc "list") s.styp)]
in
let act = <:expr< Qast.List a >> in
{prod = prod; action = Some act}
in
[r1; r2]
in
let used =
match sep with
[ Some symb -> symb.used @ s.used
| None -> s.used ]
in
let used = ["a_list" :: used] in
let text = TXrules _loc (srules _loc "a_list" rl "") in
let styp = STquo _loc "a_list" in
{used = used; text = text; styp = styp; pattern = None}
;
value ssopt _loc s =
let rl =
let r1 =
let prod =
let n = mk_name _loc <:ident< a_opt >> in
[mk_symbol <:patt< a >> (TXnterm _loc n None) (STquo _loc "a_opt")]
in
let act = <:expr< a >> in
{prod = prod; action = Some act}
in
let r2 =
let s =
match s.text with
[ TXkwd _loc _ | TXtok _loc _ _ ->
let rl =
[{prod = [{ (s) with pattern = Some <:patt< x >> }];
action = Some <:expr< Qast.Str (Token.extract_string x) >>}]
in
let t = new_type_var () in
{used = []; text = TXrules _loc (srules _loc t rl "");
styp = STquo _loc t; pattern = None}
| _ -> s ]
in
let prod =
[mk_symbol <:patt< a >> (TXopt _loc s.text)
(STapp _loc (STlid _loc "option") s.styp)]
in
let act = <:expr< Qast.Option a >> in
{prod = prod; action = Some act}
in
[r1; r2]
in
let used = ["a_opt" :: s.used] in
let text = TXrules _loc (srules _loc "a_opt" rl "") in
let styp = STquo _loc "a_opt" in
{used = used; text = text; styp = styp; pattern = None}
;
*)
value text_of_entry _loc e =
let ent =
let x = e.name in
let _loc = e.name.loc in
<:expr< ($x.expr$ : $uid:gm$.Entry.t '$x.tvar$) >>
in
let pos =
match e.pos with
[ Some pos -> <:expr< Some $pos$ >>
| None -> <:expr< None >> ]
in
let txt =
List.fold_right
(fun level txt ->
let lab =
match level.label with
[ Some lab -> <:expr< Some $str:lab$ >>
| None -> <:expr< None >> ]
in
let ass =
match level.assoc with
[ Some ass -> <:expr< Some $ass$ >>
| None -> <:expr< None >> ]
in
let txt =
let rl = srules _loc e.name.tvar level.rules e.name.tvar in
let e = make_expr_rules _loc e.name rl e.name.tvar in
<:expr< [($lab$, $ass$, $e$) :: $txt$] >>
in
txt)
e.levels <:expr< [] >>
in
(ent, pos, txt)
;
value let_in_of_extend _loc gram gl el args =
match gl with
[ None -> args
| Some nl ->
do {
check_use nl el;
let ll =
let same_tvar e n = e.name.tvar = n.tvar in
List.fold_right
(fun e ll ->
match e.name.expr with
[ <:expr< $lid:_$ >> ->
if List.exists (same_tvar e) nl then ll
else if List.exists (same_tvar e) ll then ll
else [e.name :: ll]
| _ -> ll ])
el []
in
let local_binding_of_name {expr = e; tvar = x; loc = _loc} =
let i =
match e with
[ <:expr< $lid:i$ >> -> i
| _ -> failwith "internal error in the Grammar extension" ]
in <:binding< $lid:i$ =
(grammar_entry_create $str:i$ : $uid:gm$.Entry.t '$x$) >> in
let expr_of_name {expr = e; tvar = x; loc = _loc} =
<:expr< ($e$ : $uid:gm$.Entry.t '$x$) >> in
let e =
match ll with
[ [] -> args
| [x::xs] ->
let locals =
List.fold_right
(fun name acc ->
<:binding< $acc$ and $local_binding_of_name name$ >>)
xs (local_binding_of_name x)
in
let entry_mk =
match gram with
[ Some g -> <:expr< $uid:gm$.Entry.mk $id:g$ >>
| None -> <:expr< $uid:gm$.Entry.mk >> ]
in <:expr<
let grammar_entry_create = $entry_mk$ in
let $locals$ in $args$ >> ]
in
match nl with
[ [] -> e
| [x::xs] ->
let globals =
List.fold_right
(fun name acc ->
<:binding< $acc$ and _ = $expr_of_name name$ >>)
xs <:binding< _ = $expr_of_name x$ >>
in <:expr< let $globals$ in $e$ >> ]
} ]
;
class subst gmod =
object
inherit Ast.map as super;
method ident =
fun
[ <:ident< $uid:x$ >> when x = gm -> gmod
| x -> super#ident x ];
end;
value subst_gmod ast gmod = (new subst gmod)#expr ast;
value text_of_functorial_extend _loc gmod gram gl el =
let args =
let el =
List.map
(fun e ->
let (ent, pos, txt) = text_of_entry e.name.loc e in
let e = <:expr< $uid:gm$.extend $ent$ ((fun () -> ($pos$, $txt$)) ()) >> in
if split_ext.val then <:expr< let aux () = $e$ in aux () >> else e)
el
in
match el with
[ [] -> <:expr< () >>
| [e] -> e
| [e::el] ->
<:expr< do { $List.fold_left
(fun acc x -> <:expr< $acc$; $x$ >>) e el$ } >> ]
in
subst_gmod (let_in_of_extend _loc gram gl el args) gmod;
value wildcarder = object (self)
inherit Ast.map as super;
method patt =
fun
[ <:patt@_loc< $lid:_$ >> -> <:patt< _ >>
| <:patt< ($p$ as $_$) >> -> self#patt p
| p -> super#patt p ];
end;
value mk_tok _loc p t =
let p' = wildcarder#patt p in
let match_fun =
if Ast.is_irrefut_patt p' then
<:expr< fun [ $pat:p'$ -> True ] >>
else
<:expr< fun [ $pat:p'$ -> True | _ -> False ] >> in
let descr = string_of_patt p' in
let text = TXtok _loc match_fun descr in
{used = []; text = text; styp = t; pattern = Some p };
value symbol = Gram.Entry.mk "symbol";
value check_not_tok s =
match s with
[ {text = TXtok _loc _ _ } ->
Loc.raise _loc (Stream.Error
("Deprecated syntax, use a sub rule. "^
"LIST0 STRING becomes LIST0 [ x = STRING -> x ]"))
| _ -> () ];
Camlp4_config.antiquotations.val := True;
EXTEND Gram
GLOBAL: expr symbol;
expr: AFTER "top"
[ [ "EXTEND"; e = extend_body; "END" -> e
| "DELETE_RULE"; e = delete_rule_body; "END" -> e
| "GDELETE_RULE" ->
Loc.raise _loc (Stream.Error
"Deprecated syntax, use DELETE_RULE MyGramModule ... END instead")
| "GEXTEND" ->
Loc.raise _loc (Stream.Error
"Deprecated syntax, use EXTEND MyGramModule ... END instead") ] ]
;
extend_header:
[ [ "("; i = qualid; ":"; t = t_qualid; ")" -> (Some i, t)
| g = qualuid -> (None, g) ] ]
;
extend_body:
[ [ (gram, g) = extend_header; global_list = OPT global;
el = LIST1 [ e = entry; semi_sep -> e ] ->
text_of_functorial_extend _loc g gram global_list el ] ]
;
delete_rule_body:
[ [ g = qualuid; n = name; ":"; sl = LIST0 symbol SEP semi_sep ->
let (e, b) = expr_of_delete_rule _loc n sl in
subst_gmod <:expr< $uid:gm$.delete_rule $e$ $b$ >> g ] ]
;
qualuid:
[ [ [ LIDENT | UIDENT "GLOBAL" ] ->
Loc.raise _loc
(Stream.Error
"Deprecated syntax, the grammar module is expected") ]
| [ x = UIDENT; "."; xs = SELF -> <:ident< $uid:x$.$xs$ >>
| i = UIDENT -> <:ident< $uid:i$ >> ] ]
;
qualuid:
[ [ [ LIDENT | UIDENT "GLOBAL" ] ->
Loc.raise _loc
(Stream.Error
"Deprecated syntax, the grammar module is expected") ]
| [ x = UIDENT; "."; xs = SELF -> <:ident< $uid:x$.$xs$ >>
| i = UIDENT -> <:ident< $uid:i$ >> ] ]
;
qualid:
[ [ x = UIDENT; "."; xs = SELF -> <:ident< $uid:x$.$xs$ >>
| i = UIDENT -> <:ident< $uid:i$ >>
| i = LIDENT -> <:ident< $lid:i$ >>
] ]
;
t_qualid:
[ [ x = UIDENT; "."; xs = SELF -> <:ident< $uid:x$.$xs$ >>
| x = UIDENT; "."; `LIDENT "t" -> <:ident< $uid:x$ >>
| `(LIDENT _ | UIDENT _) ->
Loc.raise _loc (Stream.Error
("Wrong EXTEND header, the grammar type must finish by 't', "^
"like in EXTEND (g : Gram.t) ... END")) ] ]
;
global:
[ [ UIDENT "GLOBAL"; ":"; sl = LIST1 name; semi_sep -> sl ] ]
;
entry:
[ [ n = name; ":"; pos = OPT position; ll = level_list ->
{name = n; pos = pos; levels = ll} ] ]
;
position:
[ [ UIDENT "FIRST" -> <:expr< Camlp4.Sig.Grammar.First >>
| UIDENT "LAST" -> <:expr< Camlp4.Sig.Grammar.Last >>
| UIDENT "BEFORE"; n = string -> <:expr< Camlp4.Sig.Grammar.Before $n$ >>
| UIDENT "AFTER"; n = string -> <:expr< Camlp4.Sig.Grammar.After $n$ >>
| UIDENT "LEVEL"; n = string -> <:expr< Camlp4.Sig.Grammar.Level $n$ >> ] ]
;
level_list:
[ [ "["; ll = LIST0 level SEP "|"; "]" -> ll ] ]
;
level:
[ [ lab = OPT [ x = STRING -> x ]; ass = OPT assoc; rules = rule_list ->
{label = lab; assoc = ass; rules = rules} ] ]
;
assoc:
[ [ UIDENT "LEFTA" -> <:expr< Camlp4.Sig.Grammar.LeftA >>
| UIDENT "RIGHTA" -> <:expr< Camlp4.Sig.Grammar.RightA >>
| UIDENT "NONA" -> <:expr< Camlp4.Sig.Grammar.NonA >> ] ]
;
rule_list:
[ [ "["; "]" -> []
| "["; rules = LIST1 rule SEP "|"; "]" ->
retype_rule_list_without_patterns _loc rules ] ]
;
rule:
[ [ psl = LIST0 psymbol SEP semi_sep; "->"; act = expr ->
{prod = psl; action = Some act}
| psl = LIST0 psymbol SEP semi_sep ->
{prod = psl; action = None} ] ]
;
psymbol:
[ [ p = LIDENT; "="; s = symbol ->
match s.pattern with
[ Some (<:patt< $uid:u$ ($tup:<:patt< _ >>$) >> as p') ->
let match_fun = <:expr< fun [ $pat:p'$ -> True | _ -> False ] >> in
let p' = <:patt< ($p'$ as $lid:p$) >> in
let descr = u ^ " _" in
let text = TXtok _loc match_fun descr in
{ (s) with text = text; pattern = Some p' }
| _ -> { (s) with pattern = Some <:patt< $lid:p$ >> } ]
| i = LIDENT; lev = OPT [ UIDENT "LEVEL"; s = STRING -> s ] ->
let name = mk_name _loc <:ident< $lid:i$ >> in
let text = TXnterm _loc name lev in
let styp = STquo _loc i in
{used = [i]; text = text; styp = styp; pattern = None}
| p = pattern; "="; s = symbol ->
match s.pattern with
[ Some <:patt< $uid:u$ ($tup:<:patt< _ >>$) >> ->
mk_tok _loc <:patt< $uid:u$ $p$ >> s.styp
| _ -> { (s) with pattern = Some p } ]
| s = symbol -> s ] ]
;
symbol:
[ "top" NONA
[ UIDENT "LIST0"; s = SELF;
sep = OPT [ UIDENT "SEP"; t = symbol -> t ] ->
let () = check_not_tok s in
let used =
match sep with
[ Some symb -> symb.used @ s.used
| None -> s.used ]
in
let styp = STapp _loc (STlid _loc "list") s.styp in
let text = slist _loc False sep s in
{used = used; text = text; styp = styp; pattern = None}
| UIDENT "LIST1"; s = SELF;
sep = OPT [ UIDENT "SEP"; t = symbol -> t ] ->
let () = check_not_tok s in
let used =
match sep with
[ Some symb -> symb.used @ s.used
| None -> s.used ]
in
let styp = STapp _loc (STlid _loc "list") s.styp in
let text = slist _loc True sep s in
{used = used; text = text; styp = styp; pattern = None}
| UIDENT "OPT"; s = SELF ->
let () = check_not_tok s in
let styp = STapp _loc (STlid _loc "option") s.styp in
let text = TXopt _loc s.text in
{used = s.used; text = text; styp = styp; pattern = None}
| UIDENT "TRY"; s = SELF ->
let text = TXtry _loc s.text in
{used = s.used; text = text; styp = s.styp; pattern = None} ]
| [ UIDENT "SELF" ->
{used = []; text = TXself _loc; styp = STself _loc "SELF"; pattern = None}
| UIDENT "NEXT" ->
{used = []; text = TXnext _loc; styp = STself _loc "NEXT"; pattern = None}
| "["; rl = LIST0 rule SEP "|"; "]" ->
let rl = retype_rule_list_without_patterns _loc rl in
let t = new_type_var () in
{used = used_of_rule_list rl;
text = TXrules _loc (srules _loc t rl "");
styp = STquo _loc t; pattern = None}
| "`"; p = patt -> mk_tok _loc p (STtok _loc)
| x = UIDENT -> mk_tok _loc <:patt< $uid:x$ ($tup:<:patt< _ >>$) >>
(STstring_tok _loc)
| x = UIDENT; s = STRING -> mk_tok _loc <:patt< $uid:x$ $str:s$ >> (STtok _loc)
| x = UIDENT; `ANTIQUOT "" s ->
let e = AntiquotSyntax.parse_expr _loc s in
let match_fun = <:expr< fun [ $uid:x$ camlp4_x when camlp4_x = $e$ -> True | _ -> False ] >> in
let descr = "$" ^ x ^ " " ^ s in
let text = TXtok _loc match_fun descr in
let p = <:patt< $uid:x$ ($tup:<:patt< _ >>$) >> in
{used = []; text = text; styp = STtok _loc; pattern = Some p }
| s = STRING ->
{used = []; text = TXkwd _loc s;
styp = STtok _loc; pattern = None }
| i = UIDENT; "."; il = qualid;
lev = OPT [ UIDENT "LEVEL"; s = STRING -> s ] ->
let n = mk_name _loc <:ident< $uid:i$.$il$ >> in
{used = [n.tvar]; text = TXnterm _loc n lev;
styp = STquo _loc n.tvar; pattern = None}
| n = name; lev = OPT [ UIDENT "LEVEL"; s = STRING -> s ] ->
{used = [n.tvar]; text = TXnterm _loc n lev;
styp = STquo _loc n.tvar; pattern = None}
| "("; s_t = SELF; ")" -> s_t ] ]
;
pattern:
[ [ i = LIDENT -> <:patt< $lid:i$ >>
| "_" -> <:patt< _ >>
| "("; p = pattern; ")" -> <:patt< $p$ >>
| "("; p1 = pattern; ","; p2 = comma_patt; ")" -> <:patt< ( $p1$, $p2$ ) >>
] ]
;
comma_patt:
[ [ p1 = SELF; ","; p2 = SELF -> <:patt< $p1$, $p2$ >>
| p = pattern -> p
] ]
;
name:
[ [ il = qualid -> mk_name _loc il ] ]
;
string:
[ [ s = STRING -> <:expr< $str:s$ >>
| `ANTIQUOT "" s -> AntiquotSyntax.parse_expr _loc s ] ]
;
semi_sep:
[ [ ";" -> () ] ]
;
END;
(*
EXTEND Gram
symbol: LEVEL "top"
[ NONA
[ min = [ UIDENT "SLIST0" -> False | UIDENT "SLIST1" -> True ];
s = SELF; sep = OPT [ UIDENT "SEP"; t = symbol -> t ] ->
sslist _loc min sep s
| UIDENT "SOPT"; s = SELF ->
ssopt _loc s ] ]
;
END;
*)
value sfold _loc n foldfun f e s =
let styp = STquo _loc (new_type_var ()) in
let e = <:expr< $uid:gm$.$lid:foldfun$ $f$ $e$ >> in
let t = STapp _loc (STapp _loc (STtyp <:ctyp< $uid:gm$.fold _ >>) s.styp) styp in
{used = s.used; text = TXmeta _loc n [s.text] e t; styp = styp; pattern = None }
;
value sfoldsep _loc n foldfun f e s sep =
let styp = STquo _loc (new_type_var ()) in
let e = <:expr< $uid:gm$.$lid:foldfun$ $f$ $e$ >> in
let t =
STapp _loc (STapp _loc (STtyp <:ctyp< $uid:gm$.foldsep _ >>) s.styp) styp
in
{used = s.used @ sep.used; text = TXmeta _loc n [s.text; sep.text] e t;
styp = styp; pattern = None}
;
EXTEND Gram
GLOBAL: symbol;
symbol: LEVEL "top"
[ [ UIDENT "FOLD0"; f = simple_expr; e = simple_expr; s = SELF ->
sfold _loc "FOLD0" "sfold0" f e s
| UIDENT "FOLD1"; f = simple_expr; e = simple_expr; s = SELF ->
sfold _loc "FOLD1" "sfold1" f e s
| UIDENT "FOLD0"; f = simple_expr; e = simple_expr; s = SELF;
UIDENT "SEP"; sep = symbol ->
sfoldsep _loc "FOLD0 SEP" "sfold0sep" f e s sep
| UIDENT "FOLD1"; f = simple_expr; e = simple_expr; s = SELF;
UIDENT "SEP"; sep = symbol ->
sfoldsep _loc "FOLD1 SEP" "sfold1sep" f e s sep ] ]
;
simple_expr:
[ [ i = a_LIDENT -> <:expr< $lid:i$ >>
| "("; e = expr; ")" -> e ] ]
;
END;
Options.add "-split_ext" (Arg.Set split_ext)
"Split EXTEND by functions to turn around a PowerPC problem.";
Options.add "-split_gext" (Arg.Set split_ext)
"Old name for the option -split_ext.";
Options.add "-meta_action" (Arg.Set meta_action)
"Undocumented"; (* FIXME *)
end;
module M = Register.OCamlSyntaxExtension Id Make;

149
camlp4/Camlp4Parsers/Camlp4ListComprehension.ml
View File

@ -1,149 +0,0 @@
open Camlp4; (* -*- camlp4r -*- *)
(****************************************************************************)
(* *)
(* OCaml *)
(* *)
(* INRIA Rocquencourt *)
(* *)
(* Copyright 2007 Institut National de Recherche en Informatique et *)
(* en Automatique. All rights reserved. This file is distributed under *)
(* the terms of the GNU Library General Public License, with the special *)
(* exception on linking described in LICENSE at the top of the OCaml *)
(* source tree. *)
(* *)
(****************************************************************************)
(* Authors:
* - Nao Hirokawa: initial version
* - Nicolas Pouillard: revised syntax version
*)
module Id = struct
value name = "Camlp4ListComprehension";
value version = Sys.ocaml_version;
end;
module Make (Syntax : Sig.Camlp4Syntax) = struct
open Sig;
include Syntax;
value rec loop n =
fun
[ [] -> None
| [(x, _)] -> if n = 1 then Some x else None
| [_ :: l] -> loop (n - 1) l ];
value stream_peek_nth n strm = loop n (Stream.npeek n strm);
(* usual trick *)
value test_patt_lessminus =
Gram.Entry.of_parser "test_patt_lessminus"
(fun strm ->
let rec skip_patt n =
match stream_peek_nth n strm with
[ Some (KEYWORD "<-") -> n
| Some (KEYWORD ("[" | "[<")) ->
skip_patt (ignore_upto "]" (n + 1) + 1)
| Some (KEYWORD "(") ->
skip_patt (ignore_upto ")" (n + 1) + 1)
| Some (KEYWORD "{") ->
skip_patt (ignore_upto "}" (n + 1) + 1)
| Some (KEYWORD ("as" | "::" | "," | "_"))
| Some (LIDENT _ | UIDENT _) -> skip_patt (n + 1)
| Some _ | None -> raise Stream.Failure ]
and ignore_upto end_kwd n =
match stream_peek_nth n strm with
[ Some (KEYWORD prm) when prm = end_kwd -> n
| Some (KEYWORD ("[" | "[<")) ->
ignore_upto end_kwd (ignore_upto "]" (n + 1) + 1)
| Some (KEYWORD "(") ->
ignore_upto end_kwd (ignore_upto ")" (n + 1) + 1)
| Some (KEYWORD "{") ->
ignore_upto end_kwd (ignore_upto "}" (n + 1) + 1)
| Some _ -> ignore_upto end_kwd (n + 1)
| None -> raise Stream.Failure ]
in
skip_patt 1);
value map _loc p e l =
match (p, e) with
[ (<:patt< $lid:x$ >>, <:expr< $lid:y$ >>) when x = y -> l
| _ ->
if Ast.is_irrefut_patt p then
<:expr< List.map (fun $p$ -> $e$) $l$ >>
else
<:expr< List.fold_right
(fun
[ $pat:p$ when True -> (fun x xs -> [ x :: xs ]) $e$
| _ -> (fun l -> l) ])
$l$ [] >> ];
value filter _loc p b l =
if Ast.is_irrefut_patt p then
<:expr< List.filter (fun $p$ -> $b$) $l$ >>
else
<:expr< List.filter (fun [ $p$ when True -> $b$ | _ -> False ]) $l$ >>;
value concat _loc l = <:expr< List.concat $l$ >>;
value rec compr _loc e =
fun
[ [`gen (p, l)] -> map _loc p e l
| [`gen (p, l); `cond b :: items] ->
compr _loc e [`gen (p, filter _loc p b l) :: items]
| [`gen (p, l) :: ([ `gen (_, _) :: _ ] as is )] ->
concat _loc (map _loc p (compr _loc e is) l)
| _ -> raise Stream.Failure ];
DELETE_RULE Gram expr: "["; sem_expr_for_list; "]" END;
value is_revised =
try do {
DELETE_RULE Gram expr: "["; sem_expr_for_list; "::"; expr; "]" END;
True
} with [ Struct.Grammar.Delete.Rule_not_found _ -> False ];
value comprehension_or_sem_expr_for_list =
Gram.Entry.mk "comprehension_or_sem_expr_for_list";
EXTEND Gram
GLOBAL: expr comprehension_or_sem_expr_for_list;
expr: LEVEL "simple"
[ [ "["; e = comprehension_or_sem_expr_for_list; "]" -> e ] ]
;
comprehension_or_sem_expr_for_list:
[ [ e = expr LEVEL "top"; ";"; mk = sem_expr_for_list ->
<:expr< [ $e$ :: $mk <:expr< [] >>$ ] >>
| e = expr LEVEL "top"; ";" -> <:expr< [$e$] >>
| e = expr LEVEL "top"; "|"; l = LIST1 item SEP ";" -> compr _loc e l
| e = expr LEVEL "top" -> <:expr< [$e$] >> ] ]
;
item:
(* NP: These rules rely on being on this particular order. Which should
be improved. *)
[ [ p = TRY [p = patt; "<-" -> p] ; e = expr LEVEL "top" -> `gen (p, e)
| e = expr LEVEL "top" -> `cond e ] ]
;
END;
if is_revised then
EXTEND Gram
GLOBAL: expr comprehension_or_sem_expr_for_list;
comprehension_or_sem_expr_for_list:
[ [ e = expr LEVEL "top"; ";"; mk = sem_expr_for_list; "::"; last = expr ->
<:expr< [ $e$ :: $mk last$ ] >>
| e = expr LEVEL "top"; "::"; last = expr ->
<:expr< [ $e$ :: $last$ ] >> ] ]
;
END
else ();
end;
let module M = Register.OCamlSyntaxExtension Id Make in ();

459
camlp4/Camlp4Parsers/Camlp4MacroParser.ml
View File

@ -1,459 +0,0 @@
open Camlp4; (* -*- camlp4r -*- *)
(****************************************************************************)
(* *)
(* OCaml *)
(* *)
(* INRIA Rocquencourt *)
(* *)
(* Copyright 2006 Institut National de Recherche en Informatique et *)
(* en Automatique. All rights reserved. This file is distributed under *)
(* the terms of the GNU Library General Public License, with the special *)
(* exception on linking described in LICENSE at the top of the OCaml *)
(* source tree. *)
(* *)
(****************************************************************************)
(* Authors:
* - Daniel de Rauglaudre: initial version
* - Nicolas Pouillard: refactoring
* - Aleksey Nogin: extra features and bug fixes.
* - Christopher Conway: extra feature (-D<uident>=)
* - Jean-vincent Loddo: definitions inside IFs.
*)
module Id = struct
value name = "Camlp4MacroParser";
value version = Sys.ocaml_version;
end;
(*
Added statements:
At toplevel (structure item):
DEFINE <uident>
DEFINE <uident> = <expression>
DEFINE <uident> (<parameters>) = <expression>
IFDEF <uident> THEN <structure_items> [ ELSE <structure_items> ] (END | ENDIF)
IFNDEF <uident> THEN <structure_items> [ ELSE <structure_items> ] (END | ENDIF)
INCLUDE <string>
At toplevel (signature item):
DEFINE <uident>
IFDEF <uident> THEN <signature_items> [ ELSE <signature_items> ] (END | ENDIF)
IFNDEF <uident> THEN <signature_items> [ ELSE <signature_items> ] (END | ENDIF)
INCLUDE <string>
In expressions:
IFDEF <uident> THEN <expression> [ ELSE <expression> ] (END | ENDIF)
IFNDEF <uident> THEN <expression> [ ELSE <expression> ] (END | ENDIF)
DEFINE <lident> = <expression> IN <expression>
__FILE__
__LOCATION__
LOCATION_OF <parameter>
In patterns:
IFDEF <uident> THEN <pattern> ELSE <pattern> (END | ENDIF)
IFNDEF <uident> THEN <pattern> ELSE <pattern> (END | ENDIF)
As Camlp4 options:
-D<uident> or -D<uident>=expr define <uident> with optional value <expr>
-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.
You can also define a local macro in an expression usigng the DEFINE ... IN form.
Note that local macros have lowercase names and can not take parameters.
If a macro is defined to = NOTHING, and then used as an argument to a function,
this will be equivalent to function taking one less argument. Similarly,
passing NOTHING as an argument to a macro is equivalent to "erasing" the
corresponding parameter from the macro body.
The toplevel statement INCLUDE <string> can be used to include a
file containing macro definitions and also any other 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.
If used inside a macro, it returns the location where the macro is
called.
The expression (LOCATION_OF parameter) returns the location of the given
macro parameter. It cannot be used outside a macro definition.
*)
open Camlp4;
module Make (Syntax : Sig.Camlp4Syntax) = struct
open Sig;
include Syntax;
type item_or_def 'a =
[ SdStr of 'a
| SdDef of string and option (list string * Ast.expr)
| SdUnd of string
| SdITE of bool and list (item_or_def 'a) and list (item_or_def 'a)
| SdLazy of Lazy.t 'a ];
value rec list_remove x =
fun
[ [(y, _) :: l] when y = x -> l
| [d :: l] -> [d :: list_remove x l]
| [] -> [] ];
value defined = ref [];
value is_defined i = List.mem_assoc i defined.val;
value bad_patt _loc =
Loc.raise _loc
(Failure
"this macro cannot be used in a pattern (see its definition)");
value substp _loc env =
loop where rec loop =
fun
[ <:expr< $e1$ $e2$ >> -> <:patt< $loop e1$ $loop e2$ >>
| <:expr< >> -> <:patt< >>
| <:expr< $lid:x$ >> ->
try List.assoc x env with
[ Not_found -> <:patt< $lid:x$ >> ]
| <:expr< $uid:x$ >> ->
try List.assoc x env with
[ Not_found -> <:patt< $uid:x$ >> ]
| <:expr< $int:x$ >> -> <:patt< $int:x$ >>
| <:expr< $str:s$ >> -> <:patt< $str:s$ >>
| <:expr< ($tup:x$) >> -> <:patt< ($tup:loop x$) >>
| <:expr< $x1$, $x2$ >> -> <:patt< $loop x1$, $loop x2$ >>
| <:expr< { $bi$ } >> ->
let rec substbi = fun
[ <:rec_binding< $b1$; $b2$ >> -> <:patt< $substbi b1$; $substbi b2$ >>
| <:rec_binding< $i$ = $e$ >> -> <:patt< $i$ = $loop e$ >>
| _ -> bad_patt _loc ]
in <:patt< { $substbi bi$ } >>
| _ -> bad_patt _loc ];
class reloc _loc = object
inherit Ast.map as super;
method loc _ = _loc;
(* method _Loc_t _ = _loc; *)
end;
class subst _loc env = object
inherit reloc _loc as super;
method expr =
fun
[ <:expr< $lid:x$ >> | <:expr< $uid:x$ >> as e ->
try List.assoc x env with
[ Not_found -> super#expr e ]
| <:expr@_loc< LOCATION_OF $lid:x$ >> | <:expr@_loc< LOCATION_OF $uid:x$ >> as e ->
try
let loc = Ast.loc_of_expr (List.assoc x env) in
let (a, b, c, d, e, f, g, h) = Loc.to_tuple loc in
<:expr< Loc.of_tuple
($`str:a$, $`int:b$, $`int:c$, $`int:d$,
$`int:e$, $`int:f$, $`int:g$,
$if h then <:expr< True >> else <:expr< False >> $) >>
with [ Not_found -> super#expr e ]
| e -> super#expr e ];
method patt =
fun
[ <:patt< $lid:x$ >> | <:patt< $uid:x$ >> as p ->
try substp _loc [] (List.assoc x env) with
[ Not_found -> super#patt p ]
| p -> super#patt p ];
end;
value incorrect_number loc l1 l2 =
Loc.raise loc
(Failure
(Printf.sprintf "expected %d parameters; found %d"
(List.length l2) (List.length l1)));
value define eo x =
do {
match eo with
[ Some ([], e) ->
EXTEND Gram
expr: LEVEL "simple"
[ [ UIDENT $x$ -> (new reloc _loc)#expr e ]]
;
patt: LEVEL "simple"
[ [ UIDENT $x$ ->
let p = substp _loc [] e
in (new reloc _loc)#patt p ]]
;
END
| Some (sl, e) ->
EXTEND Gram
expr: LEVEL "apply"
[ [ UIDENT $x$; param = SELF ->
let el =
match param with
[ <:expr< ($tup:e$) >> -> Ast.list_of_expr e []
| e -> [e] ]
in
if List.length el = List.length sl then
let env = List.combine sl el in
(new subst _loc env)#expr e
else
incorrect_number _loc el sl ] ]
;
patt: LEVEL "simple"
[ [ UIDENT $x$; param = SELF ->
let pl =
match param with
[ <:patt< ($tup:p$) >> -> Ast.list_of_patt p []
| p -> [p] ]
in
if List.length pl = List.length sl then
let env = List.combine sl pl in
let p = substp _loc env e in
(new reloc _loc)#patt p
else
incorrect_number _loc pl sl ] ]
;
END
| None -> () ];
defined.val := [(x, eo) :: defined.val];
};
value undef x =
try
do {
let eo = List.assoc x defined.val in
match eo with
[ Some ([], _) ->
do {
DELETE_RULE Gram expr: UIDENT $x$ END;
DELETE_RULE Gram patt: UIDENT $x$ END;
}
| Some (_, _) ->
do {
DELETE_RULE Gram expr: UIDENT $x$; SELF END;
DELETE_RULE Gram patt: UIDENT $x$; SELF END;
}
| None -> () ];
defined.val := list_remove x defined.val;
}
with
[ Struct.Grammar.Delete.Rule_not_found _ -> () ];
value parse_def s =
match Gram.parse_string expr (Loc.mk "<command line>") s with
[ <:expr< $uid:n$ >> -> define None n
| <:expr< $uid:n$ = $e$ >> -> define (Some ([],e)) n
| _ -> invalid_arg s ];
(* 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 parse_include_file rule =
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 ch = open_in file in
let st = Stream.of_channel ch in
Gram.parse rule (Loc.mk file) st;
value rec execute_macro nil cons =
fun
[ SdStr i -> i
| SdDef x eo -> do { define eo x; nil }
| SdUnd x -> do { undef x; nil }
| SdITE b l1 l2 -> execute_macro_list nil cons (if b then l1 else l2)
| SdLazy l -> Lazy.force l ]
and execute_macro_list nil cons = fun
[ [] -> nil
| [hd::tl] -> (* The evaluation order is important here *)
let il1 = execute_macro nil cons hd in
let il2 = execute_macro_list nil cons tl in
cons il1 il2 ]
;
(* Stack of conditionals. *)
value stack = Stack.create () ;
(* Make an SdITE value by extracting the result of the test from the stack. *)
value make_SdITE_result st1 st2 =
let test = Stack.pop stack in
SdITE test st1 st2 ;
type branch = [ Then | Else ];
(* Execute macro only if it belongs to the currently active branch. *)
value execute_macro_if_active_branch _loc nil cons branch macro_def =
let test = Stack.top stack in
let item =
if (test && branch=Then) || ((not test) && branch=Else) then
execute_macro nil cons macro_def
else (* ignore the macro *)
nil
in SdStr(item)
;
EXTEND Gram
GLOBAL: expr patt str_item sig_item;
str_item: FIRST
[ [ x = macro_def ->
execute_macro <:str_item<>> (fun a b -> <:str_item< $a$; $b$ >>) x ] ]
;
sig_item: FIRST
[ [ x = macro_def_sig ->
execute_macro <:sig_item<>> (fun a b -> <:sig_item< $a$; $b$ >>) x ] ]
;
macro_def:
[ [ "DEFINE"; i = uident; def = opt_macro_value -> SdDef i def
| "UNDEF"; i = uident -> SdUnd i
| "IFDEF"; uident_eval_ifdef; "THEN"; st1 = smlist_then; st2 = else_macro_def ->
make_SdITE_result st1 st2
| "IFNDEF"; uident_eval_ifndef; "THEN"; st1 = smlist_then; st2 = else_macro_def ->
make_SdITE_result st1 st2
| "INCLUDE"; fname = STRING ->
SdLazy (lazy (parse_include_file str_items fname)) ] ]
;
macro_def_sig:
[ [ "DEFINE"; i = uident -> SdDef i None
| "UNDEF"; i = uident -> SdUnd i
| "IFDEF"; uident_eval_ifdef; "THEN"; sg1 = sglist_then; sg2 = else_macro_def_sig ->
make_SdITE_result sg1 sg2
| "IFNDEF"; uident_eval_ifndef; "THEN"; sg1 = sglist_then; sg2 = else_macro_def_sig ->
make_SdITE_result sg1 sg2
| "INCLUDE"; fname = STRING ->
SdLazy (lazy (parse_include_file sig_items fname)) ] ]
;
uident_eval_ifdef:
[ [ i = uident -> Stack.push (is_defined i) stack ]]
;
uident_eval_ifndef:
[ [ i = uident -> Stack.push (not (is_defined i)) stack ]]
;
else_macro_def:
[ [ "ELSE"; st = smlist_else; endif -> st
| endif -> [] ] ]
;
else_macro_def_sig:
[ [ "ELSE"; st = sglist_else; endif -> st
| endif -> [] ] ]
;
else_expr:
[ [ "ELSE"; e = expr; endif -> e
| endif -> <:expr< () >> ] ]
;
smlist_then:
[ [ sml = LIST1 [ d = macro_def; semi ->
execute_macro_if_active_branch _loc <:str_item<>> (fun a b -> <:str_item< $a$; $b$ >>) Then d
| si = str_item; semi -> SdStr si ] -> sml ] ]
;
smlist_else:
[ [ sml = LIST1 [ d = macro_def; semi ->
execute_macro_if_active_branch _loc <:str_item<>> (fun a b -> <:str_item< $a$; $b$ >>) Else d
| si = str_item; semi -> SdStr si ] -> sml ] ]
;
sglist_then:
[ [ sgl = LIST1 [ d = macro_def_sig; semi ->
execute_macro_if_active_branch _loc <:sig_item<>> (fun a b -> <:sig_item< $a$; $b$ >>) Then d
| si = sig_item; semi -> SdStr si ] -> sgl ] ]
;
sglist_else:
[ [ sgl = LIST1 [ d = macro_def_sig; semi ->
execute_macro_if_active_branch _loc <:sig_item<>> (fun a b -> <:sig_item< $a$; $b$ >>) Else d
| si = sig_item; semi -> SdStr si ] -> sgl ] ]
;
endif:
[ [ "END" -> ()
| "ENDIF" -> () ] ]
;
opt_macro_value:
[ [ "("; pl = LIST1 [ x = LIDENT -> x ] SEP ","; ")"; "="; e = expr -> Some (pl, e)
| "="; e = expr -> Some ([], e)
| -> None ] ]
;
expr: LEVEL "top"
[ [ "IFDEF"; i = uident; "THEN"; e1 = expr; e2 = else_expr ->
if is_defined i then e1 else e2
| "IFNDEF"; i = uident; "THEN"; e1 = expr; e2 = else_expr ->
if is_defined i then e2 else e1
| "DEFINE"; i = LIDENT; "="; def = expr; "IN"; body = expr ->
(new subst _loc [(i, def)])#expr body ] ]
;
patt:
[ [ "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; endif ->
if is_defined i then p2 else p1 ] ]
;
uident:
[ [ i = UIDENT -> i ] ]
;
(* dirty hack to allow polymorphic variants using the introduced keywords. *)
expr: BEFORE "simple"
[ [ "`"; kwd = [ "IFDEF" | "IFNDEF" | "THEN" | "ELSE" | "END" | "ENDIF"
| "DEFINE" | "IN" ] -> <:expr< `$uid:kwd$ >>
| "`"; s = a_ident -> <:expr< ` $s$ >> ] ]
;
(* idem *)
patt: BEFORE "simple"
[ [ "`"; kwd = [ "IFDEF" | "IFNDEF" | "THEN" | "ELSE" | "END" | "ENDIF" ] ->
<:patt< `$uid:kwd$ >>
| "`"; s = a_ident -> <:patt< ` $s$ >> ] ]
;
END;
Options.add "-D" (Arg.String parse_def)
"<string> Define for IFDEF instruction.";
Options.add "-U" (Arg.String undef)
"<string> Undefine for IFDEF instruction.";
Options.add "-I" (Arg.String add_include_dir)
"<string> Add a directory to INCLUDE search path.";
end;
let module M = Register.OCamlSyntaxExtension Id Make in ();
module MakeNothing (AstFilters : Camlp4.Sig.AstFilters) = struct
open AstFilters;
open Ast;
(* Remove NOTHING and expanse __FILE__ and __LOCATION__ *)
value map_expr =
fun
[ <:expr< $e$ NOTHING >> | <:expr< fun $ <:patt< NOTHING >> $ -> $e$ >> -> e
| <:expr@_loc< $lid:"__FILE__"$ >> -> <:expr< $`str:Loc.file_name _loc$ >>
| <:expr@_loc< $lid:"__LOCATION__"$ >> ->
let (a, b, c, d, e, f, g, h) = Loc.to_tuple _loc in
<:expr< Loc.of_tuple
($`str:a$, $`int:b$, $`int:c$, $`int:d$,
$`int:e$, $`int:f$, $`int:g$,
$if h then <:expr< True >> else <:expr< False >> $) >>
| e -> e];
register_str_item_filter (Ast.map_expr map_expr)#str_item;
end;
let module M = Camlp4.Register.AstFilter Id MakeNothing in ();

Some files were not shown because too many files have changed in this diff Show More